15. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 5/24/2017 4:45:05 PM Central Daylight Time. See www.araxis.com for information about Merge. This report uses XHTML and CSS2, and is best viewed with a modern standards-compliant browser. For optimum results when printing this report, use landscape orientation and enable printing of background images and colours in your browser.

15.1 Files compared

# Location File Last Modified
1 ehmp.zip\ehmp\product\production\kids HMP1_S60.KID Tue Dec 15 14:05:18 2015 UTC
2 ehmp.zip\ehmp\product\production\kids HMP1_S60.KID Wed May 24 15:03:49 2017 UTC

15.2 Comparison summary

Description Between
Files 1 and 2
Text Blocks Lines
Unchanged 2 64970
Changed 1 2
Inserted 0 0
Removed 0 0

15.3 Comparison options

Whitespace
Character case Differences in character case are significant
Line endings Differences in line endings (CR and LF characters) are ignored
CR/LF characters Not shown in the comparison detail

15.4 Active regular expressions

No regular expressions were active.

15.5 Comparison detail

  1   KIDS Distr ibution sa ved on Jun  11, 2014@ 01:01:13
  2   HMP 1.0 -  S60
  3   **KIDS**:H MP 1.0^MD* 1.0*38^OR* 3.0*390^PS B*3.0*79^V PR*1.0*3^T IU*1.0*106 ^
  4  
  5   **INSTALL  NAME**
  6   HMP 1.0
  7   "BLD",8821 ,0)
  8   HMP 1.0^^1 ^3140611^n
  9   "BLD",8821 ,6.3)
  10   184
  11   "BLD",8821 ,10,0)
  12   ^9.63^5^5
  13   "BLD",8821 ,10,1,0)
  14   MD*1.0*38^ 1
  15   "BLD",8821 ,10,2,0)
  16   OR*3.0*390 ^1
  17   "BLD",8821 ,10,3,0)
  18   PSB*3.0*79 ^1
  19   "BLD",8821 ,10,4,0)
  20   VPR*1.0*3^ 1
  21   "BLD",8821 ,10,5,0)
  22   TIU*1.0*10 6^1
  23   "BLD",8821 ,10,"B","M D*1.0*38", 1)
  24  
  25   "BLD",8821 ,10,"B","O R*3.0*390" ,2)
  26  
  27   "BLD",8821 ,10,"B","P SB*3.0*79" ,3)
  28  
  29   "BLD",8821 ,10,"B","T IU*1.0*106 ",5)
  30  
  31   "BLD",8821 ,10,"B","V PR*1.0*3", 4)
  32  
  33   "BLD",8821 ,"KRN",0)
  34   ^9.67PA^77 9.2^20
  35   "BLD",8821 ,"KRN",.4, 0)
  36   .4
  37   "BLD",8821 ,"KRN",.40 1,0)
  38   .401
  39   "BLD",8821 ,"KRN",.40 2,0)
  40   .402
  41   "BLD",8821 ,"KRN",.40 3,0)
  42   .403
  43   "BLD",8821 ,"KRN",.5, 0)
  44   .5
  45   "BLD",8821 ,"KRN",.84 ,0)
  46   .84
  47   "BLD",8821 ,"KRN",3.6 ,0)
  48   3.6
  49   "BLD",8821 ,"KRN",3.8 ,0)
  50   3.8
  51   "BLD",8821 ,"KRN",9.2 ,0)
  52   9.2
  53   "BLD",8821 ,"KRN",9.8 ,0)
  54   9.8
  55   "BLD",8821 ,"KRN",19, 0)
  56   19
  57   "BLD",8821 ,"KRN",19. 1,0)
  58   19.1
  59   "BLD",8821 ,"KRN",101 ,0)
  60   101
  61   "BLD",8821 ,"KRN",409 .61,0)
  62   409.61
  63   "BLD",8821 ,"KRN",771 ,0)
  64   771
  65   "BLD",8821 ,"KRN",779 .2,0)
  66   779.2
  67   "BLD",8821 ,"KRN",870 ,0)
  68   870
  69   "BLD",8821 ,"KRN",898 9.51,0)
  70   8989.51
  71   "BLD",8821 ,"KRN",898 9.52,0)
  72   8989.52
  73   "BLD",8821 ,"KRN",899 4,0)
  74   8994
  75   "BLD",8821 ,"KRN","B" ,.4,.4)
  76  
  77   "BLD",8821 ,"KRN","B" ,.401,.401 )
  78  
  79   "BLD",8821 ,"KRN","B" ,.402,.402 )
  80  
  81   "BLD",8821 ,"KRN","B" ,.403,.403 )
  82  
  83   "BLD",8821 ,"KRN","B" ,.5,.5)
  84  
  85   "BLD",8821 ,"KRN","B" ,.84,.84)
  86  
  87   "BLD",8821 ,"KRN","B" ,3.6,3.6)
  88  
  89   "BLD",8821 ,"KRN","B" ,3.8,3.8)
  90  
  91   "BLD",8821 ,"KRN","B" ,9.2,9.2)
  92  
  93   "BLD",8821 ,"KRN","B" ,9.8,9.8)
  94  
  95   "BLD",8821 ,"KRN","B" ,19,19)
  96  
  97   "BLD",8821 ,"KRN","B" ,19.1,19.1 )
  98  
  99   "BLD",8821 ,"KRN","B" ,101,101)
  100  
  101   "BLD",8821 ,"KRN","B" ,409.61,40 9.61)
  102  
  103   "BLD",8821 ,"KRN","B" ,771,771)
  104  
  105   "BLD",8821 ,"KRN","B" ,779.2,779 .2)
  106  
  107   "BLD",8821 ,"KRN","B" ,870,870)
  108  
  109   "BLD",8821 ,"KRN","B" ,8989.51,8 989.51)
  110  
  111   "BLD",8821 ,"KRN","B" ,8989.52,8 989.52)
  112  
  113   "BLD",8821 ,"KRN","B" ,8994,8994 )
  114  
  115   "MBREQ")
  116   0
  117   "QUES","XP F1",0)
  118   Y
  119   "QUES","XP F1","??")
  120   ^D REP^XPD H
  121   "QUES","XP F1","A")
  122   Shall I wr ite over y our |FLAG|  File
  123   "QUES","XP F1","B")
  124   YES
  125   "QUES","XP F1","M")
  126   D XPF1^XPD IQ
  127   "QUES","XP F2",0)
  128   Y
  129   "QUES","XP F2","??")
  130   ^D DTA^XPD H
  131   "QUES","XP F2","A")
  132   Want my da ta |FLAG|  yours
  133   "QUES","XP F2","B")
  134   YES
  135   "QUES","XP F2","M")
  136   D XPF2^XPD IQ
  137   "QUES","XP I1",0)
  138   YO
  139   "QUES","XP I1","??")
  140   ^D INHIBIT ^XPDH
  141   "QUES","XP I1","A")
  142   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  143   "QUES","XP I1","B")
  144   NO
  145   "QUES","XP I1","M")
  146   D XPI1^XPD IQ
  147   "QUES","XP M1",0)
  148   PO^VA(200, :EM
  149   "QUES","XP M1","??")
  150   ^D MG^XPDH
  151   "QUES","XP M1","A")
  152   Enter the  Coordinato r for Mail  Group '|F LAG|'
  153   "QUES","XP M1","B")
  154  
  155   "QUES","XP M1","M")
  156   D XPM1^XPD IQ
  157   "QUES","XP O1",0)
  158   Y
  159   "QUES","XP O1","??")
  160   ^D MENU^XP DH
  161   "QUES","XP O1","A")
  162   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  163   "QUES","XP O1","B")
  164   NO
  165   "QUES","XP O1","M")
  166   D XPO1^XPD IQ
  167   "QUES","XP Z1",0)
  168   Y
  169   "QUES","XP Z1","??")
  170   ^D OPT^XPD H
  171   "QUES","XP Z1","A")
  172   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  173   "QUES","XP Z1","B")
  174   NO
  175   "QUES","XP Z1","M")
  176   D XPZ1^XPD IQ
  177   "QUES","XP Z2",0)
  178   Y
  179   "QUES","XP Z2","??")
  180   ^D RTN^XPD H
  181   "QUES","XP Z2","A")
  182   Want to MO VE routine s to other  CPUs
  183   "QUES","XP Z2","B")
  184   NO
  185   "QUES","XP Z2","M")
  186   D XPZ2^XPD IQ
  187   "VER")
  188   8.0^22.0
  189   **INSTALL  NAME**
  190   MD*1.0*38
  191   "BLD",8820 ,0)
  192   MD*1.0*38^ CLINICAL P ROCEDURES^ 0^3140611^ y
  193   "BLD",8820 ,1,0)
  194   ^^2^2^3131 219^
  195   "BLD",8820 ,1,1,0)
  196   This patch  creates a n event fo r broadcas ting new o r updated  data in th e
  197   "BLD",8820 ,1,2,0)
  198   Clinical O bservation s (CLiO) m odule.
  199   "BLD",8820 ,4,0)
  200   ^9.64PA^^
  201   "BLD",8820 ,6.3)
  202   174
  203   "BLD",8820 ,"INIT")
  204   EN^MDPOST3 8
  205   "BLD",8820 ,"KRN",0)
  206   ^9.67PA^77 9.2^20
  207   "BLD",8820 ,"KRN",.4, 0)
  208   .4
  209   "BLD",8820 ,"KRN",.40 1,0)
  210   .401
  211   "BLD",8820 ,"KRN",.40 2,0)
  212   .402
  213   "BLD",8820 ,"KRN",.40 3,0)
  214   .403
  215   "BLD",8820 ,"KRN",.5, 0)
  216   .5
  217   "BLD",8820 ,"KRN",.84 ,0)
  218   .84
  219   "BLD",8820 ,"KRN",3.6 ,0)
  220   3.6
  221   "BLD",8820 ,"KRN",3.8 ,0)
  222   3.8
  223   "BLD",8820 ,"KRN",9.2 ,0)
  224   9.2
  225   "BLD",8820 ,"KRN",9.8 ,0)
  226   9.8
  227   "BLD",8820 ,"KRN",9.8 ,"NM",0)
  228   ^9.68A^1^1
  229   "BLD",8820 ,"KRN",9.8 ,"NM",1,0)
  230   MDCPROTD^^ 0^B6599959
  231   "BLD",8820 ,"KRN",9.8 ,"NM","B", "MDCPROTD" ,1)
  232  
  233   "BLD",8820 ,"KRN",19, 0)
  234   19
  235   "BLD",8820 ,"KRN",19. 1,0)
  236   19.1
  237   "BLD",8820 ,"KRN",101 ,0)
  238   101
  239   "BLD",8820 ,"KRN",101 ,"NM",0)
  240   ^9.68A^1^1
  241   "BLD",8820 ,"KRN",101 ,"NM",1,0)
  242   MDC OBSERV ATION UPDA TE^^0
  243   "BLD",8820 ,"KRN",101 ,"NM","B", "MDC OBSER VATION UPD ATE",1)
  244  
  245   "BLD",8820 ,"KRN",409 .61,0)
  246   409.61
  247   "BLD",8820 ,"KRN",771 ,0)
  248   771
  249   "BLD",8820 ,"KRN",779 .2,0)
  250   779.2
  251   "BLD",8820 ,"KRN",870 ,0)
  252   870
  253   "BLD",8820 ,"KRN",898 9.51,0)
  254   8989.51
  255   "BLD",8820 ,"KRN",898 9.52,0)
  256   8989.52
  257   "BLD",8820 ,"KRN",899 4,0)
  258   8994
  259   "BLD",8820 ,"KRN","B" ,.4,.4)
  260  
  261   "BLD",8820 ,"KRN","B" ,.401,.401 )
  262  
  263   "BLD",8820 ,"KRN","B" ,.402,.402 )
  264  
  265   "BLD",8820 ,"KRN","B" ,.403,.403 )
  266  
  267   "BLD",8820 ,"KRN","B" ,.5,.5)
  268  
  269   "BLD",8820 ,"KRN","B" ,.84,.84)
  270  
  271   "BLD",8820 ,"KRN","B" ,3.6,3.6)
  272  
  273   "BLD",8820 ,"KRN","B" ,3.8,3.8)
  274  
  275   "BLD",8820 ,"KRN","B" ,9.2,9.2)
  276  
  277   "BLD",8820 ,"KRN","B" ,9.8,9.8)
  278  
  279   "BLD",8820 ,"KRN","B" ,19,19)
  280  
  281   "BLD",8820 ,"KRN","B" ,19.1,19.1 )
  282  
  283   "BLD",8820 ,"KRN","B" ,101,101)
  284  
  285   "BLD",8820 ,"KRN","B" ,409.61,40 9.61)
  286  
  287   "BLD",8820 ,"KRN","B" ,771,771)
  288  
  289   "BLD",8820 ,"KRN","B" ,779.2,779 .2)
  290  
  291   "BLD",8820 ,"KRN","B" ,870,870)
  292  
  293   "BLD",8820 ,"KRN","B" ,8989.51,8 989.51)
  294  
  295   "BLD",8820 ,"KRN","B" ,8989.52,8 989.52)
  296  
  297   "BLD",8820 ,"KRN","B" ,8994,8994 )
  298  
  299   "BLD",8820 ,"QUES",0)
  300   ^9.62^^
  301   "BLD",8820 ,"REQB",0)
  302   ^9.611^^
  303   "INIT")
  304   EN^MDPOST3 8
  305   "KRN",101, 5982,-1)
  306   0^1
  307   "KRN",101, 5982,0)
  308   MDC OBSERV ATION UPDA TE^Observa tion updat e notifica tion^^X^^^ ^^^^^CLINI CAL PROCED URES
  309   "KRN",101, 5982,1,0)
  310   ^^16^16^31 20830^
  311   "KRN",101, 5982,1,1,0 )
  312   This proto col will b e triggere d when an  observatio n in the O BS file 
  313   "KRN",101, 5982,1,2,0 )
  314   enters or  leaves VER IFIED stat us.
  315   "KRN",101, 5982,1,3,0 )
  316    
  317   "KRN",101, 5982,1,4,0 )
  318   The local  array "MDC OBS" will  be populat ed as foll ows:
  319   "KRN",101, 5982,1,5,0 )
  320    
  321   "KRN",101, 5982,1,6,0 )
  322   MDCOBS("OB S_ID","E") ="{3562723 0-5C66-49E 3-AD93-97C 269CB257D} "
  323   "KRN",101, 5982,1,7,0 )
  324   MDCOBS("OB S_ID","I") ="{3562723 0-5C66-49E 3-AD93-97C 269CB257D} "
  325   "KRN",101, 5982,1,8,0 )
  326   MDCOBS("OL D_STATUS", "E")="Veri fied"
  327   "KRN",101, 5982,1,9,0 )
  328   MDCOBS("OL D_STATUS", "I")=1
  329   "KRN",101, 5982,1,10, 0)
  330   MDCOBS("PA TIENT_ID", "E")="SIMP SON,BARTHO LOMUE"
  331   "KRN",101, 5982,1,11, 0)
  332   MDCOBS("PA TIENT_ID", "I")=2
  333   "KRN",101, 5982,1,12, 0)
  334   MDCOBS("ST ATUS","E") ="Unverifi ed"
  335   "KRN",101, 5982,1,13, 0)
  336   MDCOBS("ST ATUS","I") =0
  337   "KRN",101, 5982,1,14, 0)
  338    
  339   "KRN",101, 5982,1,15, 0)
  340   In case of  an error,  MDCOBS("E RROR") wil l be popul ated with  the error 
  341   "KRN",101, 5982,1,16, 0)
  342   number and  error tex t from Fil eMan.
  343   "KRN",101, 5982,5)
  344  
  345   "KRN",101, 5982,10,0)
  346   ^101.01PA^ 5^1
  347   "KRN",101, 5982,20)
  348   D EN^MDCPR OTD
  349   "KRN",101, 5982,99)
  350   63349,2443
  351   "KRN",101, 5982,775,0 )
  352   ^101.0775P A^^
  353   "MBREQ")
  354   1
  355   "ORD",15,1 01)
  356   101;15;;;P RO^XPDTA;P ROF1^XPDIA ;PROE1^XPD IA;PROF2^X PDIA;;PROD EL^XPDIA
  357   "ORD",15,1 01,0)
  358   PROTOCOL
  359   "PKG",557, -1)
  360   1^1
  361   "PKG",557, 0)
  362   CLINICAL P ROCEDURES^ MD^Clinica l Procedur es
  363   "PKG",557, 20,0)
  364   ^9.402P^^
  365   "PKG",557, 22,0)
  366   ^9.49I^1^1
  367   "PKG",557, 22,1,0)
  368   1.0^304042 9^3050121^ 1000000002 0
  369   "PKG",557, 22,1,"PAH" ,1,0)
  370   38^3140611 ^1085
  371   "PKG",557, 22,1,"PAH" ,1,1,0)
  372   ^^2^2^3140 611
  373   "PKG",557, 22,1,"PAH" ,1,1,1,0)
  374   This patch  creates a n event fo r broadcas ting new o r updated  data in th e
  375   "PKG",557, 22,1,"PAH" ,1,1,2,0)
  376   Clinical O bservation s (CLiO) m odule.
  377   "QUES","XP F1",0)
  378   Y
  379   "QUES","XP F1","??")
  380   ^D REP^XPD H
  381   "QUES","XP F1","A")
  382   Shall I wr ite over y our |FLAG|  File
  383   "QUES","XP F1","B")
  384   YES
  385   "QUES","XP F1","M")
  386   D XPF1^XPD IQ
  387   "QUES","XP F2",0)
  388   Y
  389   "QUES","XP F2","??")
  390   ^D DTA^XPD H
  391   "QUES","XP F2","A")
  392   Want my da ta |FLAG|  yours
  393   "QUES","XP F2","B")
  394   YES
  395   "QUES","XP F2","M")
  396   D XPF2^XPD IQ
  397   "QUES","XP I1",0)
  398   YO
  399   "QUES","XP I1","??")
  400   ^D INHIBIT ^XPDH
  401   "QUES","XP I1","A")
  402   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  403   "QUES","XP I1","B")
  404   NO
  405   "QUES","XP I1","M")
  406   D XPI1^XPD IQ
  407   "QUES","XP M1",0)
  408   PO^VA(200, :EM
  409   "QUES","XP M1","??")
  410   ^D MG^XPDH
  411   "QUES","XP M1","A")
  412   Enter the  Coordinato r for Mail  Group '|F LAG|'
  413   "QUES","XP M1","B")
  414  
  415   "QUES","XP M1","M")
  416   D XPM1^XPD IQ
  417   "QUES","XP O1",0)
  418   Y
  419   "QUES","XP O1","??")
  420   ^D MENU^XP DH
  421   "QUES","XP O1","A")
  422   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  423   "QUES","XP O1","B")
  424   NO
  425   "QUES","XP O1","M")
  426   D XPO1^XPD IQ
  427   "QUES","XP Z1",0)
  428   Y
  429   "QUES","XP Z1","??")
  430   ^D OPT^XPD H
  431   "QUES","XP Z1","A")
  432   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  433   "QUES","XP Z1","B")
  434   NO
  435   "QUES","XP Z1","M")
  436   D XPZ1^XPD IQ
  437   "QUES","XP Z2",0)
  438   Y
  439   "QUES","XP Z2","??")
  440   ^D RTN^XPD H
  441   "QUES","XP Z2","A")
  442   Want to MO VE routine s to other  CPUs
  443   "QUES","XP Z2","B")
  444   NO
  445   "QUES","XP Z2","M")
  446   D XPZ2^XPD IQ
  447   "RTN")
  448   2
  449   "RTN","MDC PROTD")
  450   0^1^B65999 59
  451   "RTN","MDC PROTD",1,0 )
  452   MDCPROTD ; HINES OIFO /BLJ - Cli O backend  driver;02  Feb 2005 ;  12/12/13  8:52pm
  453   "RTN","MDC PROTD",2,0 )
  454    ;;1.0;CLI NICAL PROC EDURES;**3 8**;Apr 01 , 2004;Bui ld 174
  455   "RTN","MDC PROTD",3,0 )
  456    ;Per VHA  Directive  2004-038,  this routi ne should  not be mod ified.
  457   "RTN","MDC PROTD",4,0 )
  458    ;
  459   "RTN","MDC PROTD",5,0 )
  460    ; Externa l Referenc es -
  461   "RTN","MDC PROTD",6,0 )
  462    ;  EN^XQO R - IA # 1 0101
  463   "RTN","MDC PROTD",7,0 )
  464    ;
  465   "RTN","MDC PROTD",8,0 )
  466   EN ;
  467   "RTN","MDC PROTD",9,0 )
  468    ; First,  we'll get  the root o bservation .
  469   "RTN","MDC PROTD",10, 0)
  470    New MDCER R,IEN
  471   "RTN","MDC PROTD",11, 0)
  472    Set IEN=$ Get(DA) If  '+IEN Wri te "IEN FO R PROTOCOL  UNDEFINED !",! Quit
  473   "RTN","MDC PROTD",12, 0)
  474    Do GETS^D IQ(704.117 ,IEN_","," .01;.08;.0 9","EINR", "^TMP(""MD COBS"",$J) ","MDCERR" )
  475   "RTN","MDC PROTD",13, 0)
  476    If $Data( MDCERR) Do   Quit
  477   "RTN","MDC PROTD",14, 0)
  478    . Set MDC OBS("ERROR ")=$Get(MD CERR("DIER R",1))_U_$ Get(MDCERR ("DIERR",1 ,"TEXT",1) )
  479   "RTN","MDC PROTD",15, 0)
  480    Merge MDC OBS=^TMP(" MDCOBS",$J ,704.117,I EN_",") Ki ll ^TMP("M DCOBS",$J)
  481   "RTN","MDC PROTD",16, 0)
  482    Set MDCOB S("OLD_STA TUS","E")= $$EXTERNAL ^DILFD(704 .117,".09" ,,$Get(X1) )
  483   "RTN","MDC PROTD",17, 0)
  484    Set MDCOB S("OLD_STA TUS","I")= X1
  485   "RTN","MDC PROTD",18, 0)
  486    Set MDCOB S("DOMAIN" ,"VITALS") =0
  487   "RTN","MDC PROTD",19, 0)
  488    Set MDGUI D=$$GET1^D IQ(704.117 ,IEN_",",. 07)
  489   "RTN","MDC PROTD",20, 0)
  490    For Y=1:1  Quit:$Tex t(MAP+Y)=" "  If $Pie ce($Text(M AP+Y),";", 4)=MDGUID  Set MDCOBS ("DOMAIN", "VITALS")= 1 Quit
  491   "RTN","MDC PROTD",21, 0)
  492    Quit
  493   "RTN","MDC PROTD",22, 0)
  494    ;
  495   "RTN","MDC PROTD",23, 0)
  496   PROT ;Call  the proto col.
  497   "RTN","MDC PROTD",24, 0)
  498    Set X="MD C OBSERVAT ION UPDATE ",DIC="101 "
  499   "RTN","MDC PROTD",25, 0)
  500    Do EN^XQO R
  501   "RTN","MDC PROTD",26, 0)
  502    Quit
  503   "RTN","MDC PROTD",27, 0)
  504    ;
  505   "RTN","MDC PROTD",28, 0)
  506    ; This mu st be upda ted if Vit als EVER a dds a new  term that  we map to.  This only  says our  term it pa ired with  a vital si gn.
  507   "RTN","MDC PROTD",29, 0)
  508    ;
  509   "RTN","MDC PROTD",30, 0)
  510   MAP ; Cont ains the m appings fr om Vitals  to CliO -  vital;abbv ;vuid;term _guid
  511   "RTN","MDC PROTD",31, 0)
  512    ;;ABDOMIN AL GIRTH;{ F70E6642-2 719-22BE-B E87-DEF0A8 84F177}
  513   "RTN","MDC PROTD",32, 0)
  514    ;;AUDIOME TRY;{FFD29 134-8BB2-2 48E-0412-9 3C2C08B076 F}
  515   "RTN","MDC PROTD",33, 0)
  516    ;;BLOOD P RESSURE;{B 15F2DF6-CE 99-B847-FE 6B-3D5F174 A2BCD}
  517   "RTN","MDC PROTD",34, 0)
  518    ;;CENTRAL  VENOUS PR ESSURE;{D3 0F98A7-4C5 D-12E8-AB4 D-9C85A433 2EC3}
  519   "RTN","MDC PROTD",35, 0)
  520    ;;CIRCUMF ERENCE/GIR TH;{92A124 D4-B75F-9F D9-1A51-60 5887BCEA79 };
  521   "RTN","MDC PROTD",36, 0)
  522    ;;FETAL H EART TONES ;{A2E22A44 -E924-ADDE -2B8E-0251 666B4DE6}
  523   "RTN","MDC PROTD",37, 0)
  524    ;;FUNDAL  HEIGHT;{EE AB8762-624 F-7BA3-400 1-114FD229 BA69}
  525   "RTN","MDC PROTD",38, 0)
  526    ;;HEAD CI RCUMFERENC E;{33827E3 C-5DBB-083 C-D8BE-4DF D7D42071F}
  527   "RTN","MDC PROTD",39, 0)
  528    ;;HEARING ;{813CCC94 -3D64-5093 -BC6C-053E FD9948F9}
  529   "RTN","MDC PROTD",40, 0)
  530    ;;HEIGHT; {B440216B- 0FB3-1950- 7859-7C1BE 398FE4A}
  531   "RTN","MDC PROTD",41, 0)
  532    ;;PAIN;{4 7A83DEA-BA 95-38AD-DF 2E-1F20912 2E684}
  533   "RTN","MDC PROTD",42, 0)
  534    ;;PULSE;{ FCA63B76-E F4C-EBE5-3 3C1-F1EEBD 7A7BC4}
  535   "RTN","MDC PROTD",43, 0)
  536    ;;PULSE O XIMETRY;{5 F84DD55-3C CF-094C-25 36-B51EB7F AD999}
  537   "RTN","MDC PROTD",44, 0)
  538    ;;RESPIRA TION;{973E D2C0-0625- 7DF9-17DC- 8FFF7E376F 23}
  539   "RTN","MDC PROTD",45, 0)
  540    ;;TEMPERA TURE;{0F33 223E-DF2C- 6B8B-5201- 5E091C5F90 65}
  541   "RTN","MDC PROTD",46, 0)
  542    ;;TONOMET RY;{C06989 EF-4B0F-49 41-B1A7-FA 9D81A480FF }
  543   "RTN","MDC PROTD",47, 0)
  544    ;;VISION  CORRECTED; {ED022AC1- EBE4-E708- 684D-63D00 628A94C}
  545   "RTN","MDC PROTD",48, 0)
  546    ;;VISION  UNCORRECTE D;{BEA5E56 5-D728-F5B 3-0A3A-052 8C42A45C4}
  547   "RTN","MDC PROTD",49, 0)
  548    ;;WEIGHT; {CD2D8263- 6B71-0E1C- 0AFE-87B4B 2C12632}
  549   "RTN","MDP OST38")
  550   0^^B228306 4
  551   "RTN","MDP OST38",1,0 )
  552   MDPOST38 ; HINES OIFO /MKB - Pos t Installa tion Tasks ;02 Mar 20 08 ; 12/12 /13 8:52pm
  553   "RTN","MDP OST38",2,0 )
  554    ;;1.0;CLI NICAL PROC EDURES;**3 8**;Apr 01 , 2004;Bui ld 174
  555   "RTN","MDP OST38",3,0 )
  556    ;Per VHA  Directive  2004-038,  this routi ne should  not be mod ified.
  557   "RTN","MDP OST38",4,0 )
  558    ;
  559   "RTN","MDP OST38",5,0 )
  560    ; Externa l Referenc es -
  561   "RTN","MDP OST38",6,0 )
  562    ;  CREIXN ^DDMOD - I A # 2916
  563   "RTN","MDP OST38",7,0 )
  564    ;
  565   "RTN","MDP OST38",8,0 )
  566   EN ; -- cr eate ASTAT US index o n OBS file  #704.117
  567   "RTN","MDP OST38",9,0 )
  568    Q:$O(^DD( "IX","BB", 704.117,"A STATUS",0) )  ;exists
  569   "RTN","MDP OST38",10, 0)
  570    N VPRX,VP RY
  571   "RTN","MDP OST38",11, 0)
  572    S VPRX("F ILE")=704. 117,VPRX(" NAME")="AS TATUS"
  573   "RTN","MDP OST38",12, 0)
  574    S VPRX("T YPE")="MU" ,VPRX("USE ")="A"
  575   "RTN","MDP OST38",13, 0)
  576    S VPRX("E XECUTION") ="F",VPRX( "ACTIVITY" )=""
  577   "RTN","MDP OST38",14, 0)
  578    S VPRX("S HORT DESCR ")="Used t o trigger  MD OBSERVA TION UPDAT E protocol "
  579   "RTN","MDP OST38",15, 0)
  580    S VPRX("D ESCR",1)=" This index  invokes t he MD OBSE RVATION UP DATE proto col when t he"
  581   "RTN","MDP OST38",16, 0)
  582    S VPRX("D ESCR",2)=" status of  OBS data i s changed  to or from  verified. "
  583   "RTN","MDP OST38",17, 0)
  584    S VPRX("D ESCR",3)=" No actual  cross-refe rence node s are set  or killed. "
  585   "RTN","MDP OST38",18, 0)
  586    S VPRX("S ET")="D:(( X1=""1"")! (X2=""1"") ) PROT^MDC PROTD Q"
  587   "RTN","MDP OST38",19, 0)
  588    S VPRX("K ILL")="Q", VPRX("WHOL E KILL")=" Q"
  589   "RTN","MDP OST38",20, 0)
  590    S VPRX("V AL",1)=.09              ;Status
  591   "RTN","MDP OST38",21, 0)
  592    D CREIXN^ DDMOD(.VPR X,"",.VPRY ) ;VPRY=ie n^name of  index
  593   "RTN","MDP OST38",22, 0)
  594    Q
  595   "VER")
  596   8.0^22.0
  597   **INSTALL  NAME**
  598   OR*3.0*390
  599   "BLD",8850 ,0)
  600   OR*3.0*390 ^ORDER ENT RY/RESULTS  REPORTING ^0^3140611 ^y
  601   "BLD",8850 ,4,0)
  602   ^9.64PA^^
  603   "BLD",8850 ,6.3)
  604   110
  605   "BLD",8850 ,"KRN",0)
  606   ^9.67PA^77 9.2^20
  607   "BLD",8850 ,"KRN",.4, 0)
  608   .4
  609   "BLD",8850 ,"KRN",.40 1,0)
  610   .401
  611   "BLD",8850 ,"KRN",.40 2,0)
  612   .402
  613   "BLD",8850 ,"KRN",.40 3,0)
  614   .403
  615   "BLD",8850 ,"KRN",.5, 0)
  616   .5
  617   "BLD",8850 ,"KRN",.84 ,0)
  618   .84
  619   "BLD",8850 ,"KRN",3.6 ,0)
  620   3.6
  621   "BLD",8850 ,"KRN",3.8 ,0)
  622   3.8
  623   "BLD",8850 ,"KRN",9.2 ,0)
  624   9.2
  625   "BLD",8850 ,"KRN",9.8 ,0)
  626   9.8
  627   "BLD",8850 ,"KRN",9.8 ,"NM",0)
  628   ^9.68A^4^4
  629   "BLD",8850 ,"KRN",9.8 ,"NM",1,0)
  630   ORCACT1^^0 ^B49643037
  631   "BLD",8850 ,"KRN",9.8 ,"NM",2,0)
  632   ORCSEND^^0 ^B65938879
  633   "BLD",8850 ,"KRN",9.8 ,"NM",3,0)
  634   ORMBLDOR^^ 0^B5650360
  635   "BLD",8850 ,"KRN",9.8 ,"NM",4,0)
  636   ORWDXA^^0^ B83177974
  637   "BLD",8850 ,"KRN",9.8 ,"NM","B", "ORCACT1", 1)
  638  
  639   "BLD",8850 ,"KRN",9.8 ,"NM","B", "ORCSEND", 2)
  640  
  641   "BLD",8850 ,"KRN",9.8 ,"NM","B", "ORMBLDOR" ,3)
  642  
  643   "BLD",8850 ,"KRN",9.8 ,"NM","B", "ORWDXA",4 )
  644  
  645   "BLD",8850 ,"KRN",19, 0)
  646   19
  647   "BLD",8850 ,"KRN",19. 1,0)
  648   19.1
  649   "BLD",8850 ,"KRN",101 ,0)
  650   101
  651   "BLD",8850 ,"KRN",101 ,"NM",0)
  652   ^9.68A^1^1
  653   "BLD",8850 ,"KRN",101 ,"NM",1,0)
  654   OR EVSEND  VPR^^0
  655   "BLD",8850 ,"KRN",101 ,"NM","B", "OR EVSEND  VPR",1)
  656  
  657   "BLD",8850 ,"KRN",409 .61,0)
  658   409.61
  659   "BLD",8850 ,"KRN",771 ,0)
  660   771
  661   "BLD",8850 ,"KRN",779 .2,0)
  662   779.2
  663   "BLD",8850 ,"KRN",870 ,0)
  664   870
  665   "BLD",8850 ,"KRN",898 9.51,0)
  666   8989.51
  667   "BLD",8850 ,"KRN",898 9.52,0)
  668   8989.52
  669   "BLD",8850 ,"KRN",899 4,0)
  670   8994
  671   "BLD",8850 ,"KRN","B" ,.4,.4)
  672  
  673   "BLD",8850 ,"KRN","B" ,.401,.401 )
  674  
  675   "BLD",8850 ,"KRN","B" ,.402,.402 )
  676  
  677   "BLD",8850 ,"KRN","B" ,.403,.403 )
  678  
  679   "BLD",8850 ,"KRN","B" ,.5,.5)
  680  
  681   "BLD",8850 ,"KRN","B" ,.84,.84)
  682  
  683   "BLD",8850 ,"KRN","B" ,3.6,3.6)
  684  
  685   "BLD",8850 ,"KRN","B" ,3.8,3.8)
  686  
  687   "BLD",8850 ,"KRN","B" ,9.2,9.2)
  688  
  689   "BLD",8850 ,"KRN","B" ,9.8,9.8)
  690  
  691   "BLD",8850 ,"KRN","B" ,19,19)
  692  
  693   "BLD",8850 ,"KRN","B" ,19.1,19.1 )
  694  
  695   "BLD",8850 ,"KRN","B" ,101,101)
  696  
  697   "BLD",8850 ,"KRN","B" ,409.61,40 9.61)
  698  
  699   "BLD",8850 ,"KRN","B" ,771,771)
  700  
  701   "BLD",8850 ,"KRN","B" ,779.2,779 .2)
  702  
  703   "BLD",8850 ,"KRN","B" ,870,870)
  704  
  705   "BLD",8850 ,"KRN","B" ,8989.51,8 989.51)
  706  
  707   "BLD",8850 ,"KRN","B" ,8989.52,8 989.52)
  708  
  709   "BLD",8850 ,"KRN","B" ,8994,8994 )
  710  
  711   "BLD",8850 ,"QUES",0)
  712   ^9.62^^
  713   "BLD",8850 ,"REQB",0)
  714   ^9.611^4^4
  715   "BLD",8850 ,"REQB",1, 0)
  716   OR*3.0*97^ 2
  717   "BLD",8850 ,"REQB",2, 0)
  718   OR*3.0*284 ^2
  719   "BLD",8850 ,"REQB",3, 0)
  720   OR*3.0*296 ^2
  721   "BLD",8850 ,"REQB",4, 0)
  722   OR*3.0*306 ^2
  723   "BLD",8850 ,"REQB","B ","OR*3.0* 284",2)
  724  
  725   "BLD",8850 ,"REQB","B ","OR*3.0* 296",3)
  726  
  727   "BLD",8850 ,"REQB","B ","OR*3.0* 306",4)
  728  
  729   "BLD",8850 ,"REQB","B ","OR*3.0* 97",1)
  730  
  731   "KRN",101, 6053,-1)
  732   0^1
  733   "KRN",101, 6053,0)
  734   OR EVSEND  VPR^OE/RR  => VPR MES SAGE EVENT ^^X^^^^^^^ ^
  735   "KRN",101, 6053,10,0)
  736   ^101.01PA^ 7^1
  737   "KRN",101, 6053,99)
  738   63349,2443
  739   "MBREQ")
  740   1
  741   "ORD",15,1 01)
  742   101;15;;;P RO^XPDTA;P ROF1^XPDIA ;PROE1^XPD IA;PROF2^X PDIA;;PROD EL^XPDIA
  743   "ORD",15,1 01,0)
  744   PROTOCOL
  745   "PKG",170, -1)
  746   1^1
  747   "PKG",170, 0)
  748   ORDER ENTR Y/RESULTS  REPORTING^ OR^Order E ntry/Resul ts Reporti ng
  749   "PKG",170, 22,0)
  750   ^9.49I^1^1
  751   "PKG",170, 22,1,0)
  752   3.0^297121 7^2980917^ 11712
  753   "PKG",170, 22,1,"PAH" ,1,0)
  754   390^314061 1^1085
  755   "QUES","XP F1",0)
  756   Y
  757   "QUES","XP F1","??")
  758   ^D REP^XPD H
  759   "QUES","XP F1","A")
  760   Shall I wr ite over y our |FLAG|  File
  761   "QUES","XP F1","B")
  762   YES
  763   "QUES","XP F1","M")
  764   D XPF1^XPD IQ
  765   "QUES","XP F2",0)
  766   Y
  767   "QUES","XP F2","??")
  768   ^D DTA^XPD H
  769   "QUES","XP F2","A")
  770   Want my da ta |FLAG|  yours
  771   "QUES","XP F2","B")
  772   YES
  773   "QUES","XP F2","M")
  774   D XPF2^XPD IQ
  775   "QUES","XP I1",0)
  776   YO
  777   "QUES","XP I1","??")
  778   ^D INHIBIT ^XPDH
  779   "QUES","XP I1","A")
  780   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  781   "QUES","XP I1","B")
  782   NO
  783   "QUES","XP I1","M")
  784   D XPI1^XPD IQ
  785   "QUES","XP M1",0)
  786   PO^VA(200, :EM
  787   "QUES","XP M1","??")
  788   ^D MG^XPDH
  789   "QUES","XP M1","A")
  790   Enter the  Coordinato r for Mail  Group '|F LAG|'
  791   "QUES","XP M1","B")
  792  
  793   "QUES","XP M1","M")
  794   D XPM1^XPD IQ
  795   "QUES","XP O1",0)
  796   Y
  797   "QUES","XP O1","??")
  798   ^D MENU^XP DH
  799   "QUES","XP O1","A")
  800   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  801   "QUES","XP O1","B")
  802   NO
  803   "QUES","XP O1","M")
  804   D XPO1^XPD IQ
  805   "QUES","XP Z1",0)
  806   Y
  807   "QUES","XP Z1","??")
  808   ^D OPT^XPD H
  809   "QUES","XP Z1","A")
  810   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  811   "QUES","XP Z1","B")
  812   NO
  813   "QUES","XP Z1","M")
  814   D XPZ1^XPD IQ
  815   "QUES","XP Z2",0)
  816   Y
  817   "QUES","XP Z2","??")
  818   ^D RTN^XPD H
  819   "QUES","XP Z2","A")
  820   Want to MO VE routine s to other  CPUs
  821   "QUES","XP Z2","B")
  822   NO
  823   "QUES","XP Z2","M")
  824   D XPZ2^XPD IQ
  825   "RTN")
  826   4
  827   "RTN","ORC ACT1")
  828   0^1^B49643 037
  829   "RTN","ORC ACT1",1,0)
  830   ORCACT1 ;S LC/MKB-Act  on orders  cont ;7/2 9/97  08:2 6
  831   "RTN","ORC ACT1",2,0)
  832    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**7 ,27,56,48, 86,92,116, 149,215,28 4,390**;De c 17, 1997 ;Build 110
  833   "RTN","ORC ACT1",3,0)
  834    ;
  835   "RTN","ORC ACT1",4,0)
  836   FLAG ; --  flag order s
  837   "RTN","ORC ACT1",5,0)
  838    D EN("FL" ) Q
  839   "RTN","ORC ACT1",6,0)
  840    ;
  841   "RTN","ORC ACT1",7,0)
  842   UNFLAG ; - - unflag o rders
  843   "RTN","ORC ACT1",8,0)
  844    D EN("UF" ) Q
  845   "RTN","ORC ACT1",9,0)
  846    ;
  847   "RTN","ORC ACT1",10,0 )
  848   COMMENT ;  -- add war d comments  to orders
  849   "RTN","ORC ACT1",11,0 )
  850    D EN("CM" ) Q
  851   "RTN","ORC ACT1",12,0 )
  852    ;
  853   "RTN","ORC ACT1",13,0 )
  854   ALERT ; --  alert pro vider when  results a vailable
  855   "RTN","ORC ACT1",14,0 )
  856    D EN("AL" ) Q
  857   "RTN","ORC ACT1",15,0 )
  858    ;
  859   "RTN","ORC ACT1",16,0 )
  860   UNHOLD ; - - release  hold on or ders - no  longer in  use
  861   "RTN","ORC ACT1",17,0 )
  862    Q  ; see  UNHOLD^ORC ACT instea d
  863   "RTN","ORC ACT1",18,0 )
  864    ;
  865   "RTN","ORC ACT1",19,0 )
  866   EN(ORACT)  ; -- Actio ns that do n't create  orders
  867   "RTN","ORC ACT1",20,0 )
  868    ;    ORNM BR = #,#,. ..,# of se lected ord ers
  869   "RTN","ORC ACT1",21,0 )
  870    ;    ORAC T  = actio n to be ta ken
  871   "RTN","ORC ACT1",22,0 )
  872    ;
  873   "RTN","ORC ACT1",23,0 )
  874    ;    OREB UILD defin ed on retu rn if Orde rs tab nee ds to be r ebuilt
  875   "RTN","ORC ACT1",24,0 )
  876    ;
  877   "RTN","ORC ACT1",25,0 )
  878    N ORLK,OR I,NMBR,IDX ,ORIFN,ORD ITM,ORERR, ORQUIT
  879   "RTN","ORC ACT1",26,0 )
  880    I '$G(ORN MBR) S ORN MBR=$$ORDE RS^ORCHART ("") Q:'OR NMBR
  881   "RTN","ORC ACT1",27,0 )
  882    D FREEZE^ ORCMENU S  VALMBCK="R " K OREBUI LD
  883   "RTN","ORC ACT1",28,0 )
  884    F ORI=1:1 :$L(ORNMBR ,",") S NM BR=$P(ORNM BR,",",ORI ) D:NMBR   Q:$D(ORQUI T)
  885   "RTN","ORC ACT1",29,0 )
  886    . S IDX=$ G(^TMP("OR ",$J,ORTAB ,"IDX",NMB R)),ORIFN= $P(IDX,U)
  887   "RTN","ORC ACT1",30,0 )
  888    . Q:'ORIF N  S:'$P(O RIFN,";",2 ) ORIFN=+O RIFN_";1"
  889   "RTN","ORC ACT1",31,0 )
  890    . I '$D(^ OR(100,+OR IFN,0)) W  !,"This or der has be en deleted !" H 1 Q
  891   "RTN","ORC ACT1",32,0 )
  892    . S ORDIT M=$$ORDITE M^ORCACT(O RIFN) D SU BHDR^ORCAC T(ORDITM)
  893   "RTN","ORC ACT1",33,0 )
  894    . I '$$VA LID^ORCACT 0(ORIFN,OR ACT,.ORERR ) W !,ORER R H 1 Q
  895   "RTN","ORC ACT1",34,0 )
  896    . S ORLK= $$LOCK1^OR X2(+ORIFN)  I 'ORLK W  !,$P(ORLK ,U,2) H 1  Q
  897   "RTN","ORC ACT1",35,0 )
  898    . D @ORAC T,UNLK1^OR X2(+ORIFN)
  899   "RTN","ORC ACT1",36,0 )
  900   ENQ Q
  901   "RTN","ORC ACT1",37,0 )
  902    ;
  903   "RTN","ORC ACT1",38,0 )
  904   FL ; -- Fl ag order O RIFN
  905   "RTN","ORC ACT1",39,0 )
  906    D EN^ORCF LAG
  907   "RTN","ORC ACT1",40,0 )
  908    Q
  909   "RTN","ORC ACT1",41,0 )
  910    ;
  911   "RTN","ORC ACT1",42,0 )
  912   UF ; -- Un flag order  ORIFN
  913   "RTN","ORC ACT1",43,0 )
  914    D UN^ORCF LAG
  915   "RTN","ORC ACT1",44,0 )
  916    Q
  917   "RTN","ORC ACT1",45,0 )
  918    ;
  919   "RTN","ORC ACT1",46,0 )
  920   CM ; -- Wa rd Comment s on order  ORIFN
  921   "RTN","ORC ACT1",47,0 )
  922    N DIC,DWP K,DIWEPSE, DIWESUB,DD WRW
  923   "RTN","ORC ACT1",48,0 )
  924    S DIC="^O R(100,"_+O RIFN_",8," _+$P(ORIFN ,";",2)_", 5,",(DWPK, DIWEPSE)=1
  925   "RTN","ORC ACT1",49,0 )
  926    S DIWESUB =ORDITM,DD WRW="B" ;g o to botto m of text
  927   "RTN","ORC ACT1",50,0 )
  928    D EN^DIWE
  929   "RTN","ORC ACT1",51,0 )
  930    Q
  931   "RTN","ORC ACT1",52,0 )
  932    ;
  933   "RTN","ORC ACT1",53,0 )
  934   AL ; -- Al ert when r esults are  available  for order  ORIFN
  935   "RTN","ORC ACT1",54,0 )
  936    S $P(^OR( 100,+ORIFN ,3),U,10)= 1
  937   "RTN","ORC ACT1",55,0 )
  938    W !?10,". .. done."  H 1
  939   "RTN","ORC ACT1",56,0 )
  940    Q
  941   "RTN","ORC ACT1",57,0 )
  942    ;
  943   "RTN","ORC ACT1",58,0 )
  944   RL ; -- Re lease hold  on order  ORIFN [No  longer use d]
  945   "RTN","ORC ACT1",59,0 )
  946    D EN^ORCS END(+ORIFN ,ORACT,3,1 ,,,.ORERR)
  947   "RTN","ORC ACT1",60,0 )
  948    W !,"...  order "_$S ($G(ORERR) :"not ",1: "")_"relea sed from h old."
  949   "RTN","ORC ACT1",61,0 )
  950    W:$L($P($ G(ORERR),U ,2)) !,"   >> "_$P(OR ERR,U,2) H  1
  951   "RTN","ORC ACT1",62,0 )
  952    S OREBUIL D=1 ; prin t?
  953   "RTN","ORC ACT1",63,0 )
  954    Q
  955   "RTN","ORC ACT1",64,0 )
  956    ;
  957   "RTN","ORC ACT1",65,0 )
  958   VERIFY(ORV ER) ; -- V erify orde rs
  959   "RTN","ORC ACT1",66,0 )
  960    N ORLK,OR I,NMBR,IDX ,ORIFN,ORD ITM,ORES,O RERR,ORSIG ,OROLDSTS, ORNEW,ORWA IT
  961   "RTN","ORC ACT1",67,0 )
  962    I "^"[$G( ORVER) W $ C(7),!!,"Y ou must be  a nurse o r clerk to  verify th ese orders !" S VALMB CK="" H 2  Q
  963   "RTN","ORC ACT1",68,0 )
  964    I '$G(ORN MBR) S ORN MBR=$$ORDE RS^ORCHART ("") Q:'OR NMBR
  965   "RTN","ORC ACT1",69,0 )
  966    D FREEZE^ ORCMENU S  VALMBCK="R " K OREBUI LD
  967   "RTN","ORC ACT1",70,0 )
  968    F ORI=1:1 :$L(ORNMBR ,",") S NM BR=$P(ORNM BR,",",ORI ) D:NMBR   Q:$D(ORQUI T)
  969   "RTN","ORC ACT1",71,0 )
  970    . S IDX=$ G(^TMP("OR ",$J,ORTAB ,"IDX",NMB R)),ORIFN= $P(IDX,U)
  971   "RTN","ORC ACT1",72,0 )
  972    . Q:'ORIF N  S:'$P(O RIFN,";",2 ) ORIFN=+O RIFN_";1"  Q:$D(ORES( ORIFN))
  973   "RTN","ORC ACT1",73,0 )
  974    . I '$$VA LID^ORCACT 0(ORIFN,"V R",.ORERR)  W !!,$$OR DITEM^ORCA CT(ORIFN)_ " invalid. ",!,"  >>  "_ORERR H  1 Q
  975   "RTN","ORC ACT1",74,0 )
  976    . S ORLK= $$LOCK1^OR X2(+ORIFN)  I 'ORLK W  !!,$$ORDI TEM^ORCACT (ORIFN)_"  invalid.", !,"  >> "_ $P(ORLK,U, 2) H 1 Q
  977   "RTN","ORC ACT1",75,0 )
  978    . S ORES( ORIFN)=""  D REPLCD
  979   "RTN","ORC ACT1",76,0 )
  980   VR1 Q:'$O( ORES(0))   D COMPLX S  ORSIG=$S( $$ESIG^ORC SIGN:1,1:0 )
  981   "RTN","ORC ACT1",77,0 )
  982    I 'ORSIG  W !,"Nothi ng verifie d!" D UNLO CK H 1 Q
  983   "RTN","ORC ACT1",78,0 )
  984    W !!,"Ver ifying ord ers ..."
  985   "RTN","ORC ACT1",79,0 )
  986    S ORIFN=0  F  S ORIF N=$O(ORES( ORIFN)) Q: ORIFN'>0   D
  987   "RTN","ORC ACT1",80,0 )
  988    . S OROLD STS=+$P($G (^OR(100,+ ORIFN,3)), U,3)
  989   "RTN","ORC ACT1",81,0 )
  990    . D EN^OR CSEND(ORIF N,"VR","", "",,,.ORER R),UNLK1^O RX2(+ORIFN )
  991   "RTN","ORC ACT1",82,0 )
  992    . I $G(OR ERR) D  Q
  993   "RTN","ORC ACT1",83,0 )
  994    . . W !,$ $ORDITEM^O RCACT(ORIF N)_" not v erified."
  995   "RTN","ORC ACT1",84,0 )
  996    . . W:$L( $P($G(ORER R),U,2)) ! ,"  >> "_$ P(ORERR,U, 2) H 1
  997   "RTN","ORC ACT1",85,0 )
  998    . S ORNEW =+$P($G(^O R(100,+ORI FN,3)),U,3 ) I ORNEW' =OROLDSTS  W !,$$ORDI TEM^ORCACT (ORIFN)_"  is now "_$ $STS(ORNEW )_"." S OR WAIT=1
  999   "RTN","ORC ACT1",86,0 )
  1000    S OREBUIL D=1 D:'$D( XQAID) CKA LERT I $G( ORWAIT) H  2
  1001   "RTN","ORC ACT1",87,0 )
  1002   VRQ Q
  1003   "RTN","ORC ACT1",88,0 )
  1004    ;
  1005   "RTN","ORC ACT1",89,0 )
  1006   STS(X) ; - - Return n ame of sta tus X
  1007   "RTN","ORC ACT1",90,0 )
  1008    N Y S Y=$ P($G(^ORD( 100.01,+$G (X),0)),U)
  1009   "RTN","ORC ACT1",91,0 )
  1010    Q Y
  1011   "RTN","ORC ACT1",92,0 )
  1012    ;
  1013   "RTN","ORC ACT1",93,0 )
  1014   REPLCD ; - - Ck for u nverified  replaced o rders for  ORIFN, add  to ORES(o rder#)
  1015   "RTN","ORC ACT1",94,0 )
  1016    ;    [Exp ects ORVER ; also cal led from V ERIFY^ORWD XA,VERIFY^ ORRCOR]
  1017   "RTN","ORC ACT1",95,0 )
  1018    N OR3,ORI G,ORFLD,OR DA,ORI,ORL K
  1019   "RTN","ORC ACT1",96,0 )
  1020    S ORFLD=$ S($G(ORVER )="N":8,$G (ORVER)="R ":18,1:10) ,ORDA=+$P( ORIFN,";", 2)
  1021   "RTN","ORC ACT1",97,0 )
  1022    I ORDA>1  D  Q  ;ck  for prior  unverified  actions
  1023   "RTN","ORC ACT1",98,0 )
  1024    . ;Q:$P($ G(^OR(100, +ORIFN,8,O RDA,0)),U, 2)'="XX"
  1025   "RTN","ORC ACT1",99,0 )
  1026    . S ORI=0  F  S ORI= $O(^OR(100 ,+ORIFN,8, ORI)) Q:OR I<1  Q:ORI '<ORDA  D
  1027   "RTN","ORC ACT1",100, 0)
  1028    .. Q:$P($ G(^OR(100, +ORIFN,8,O RI,0)),U,O RFLD)  ;al ready veri fied
  1029   "RTN","ORC ACT1",101, 0)
  1030    .. S ORLK =$$LOCK1^O RX2(+ORIFN ) Q:'ORLK
  1031   "RTN","ORC ACT1",102, 0)
  1032    .. S ORES (+ORIFN_"; "_ORI)=""
  1033   "RTN","ORC ACT1",103, 0)
  1034    S OR3=$G( ^OR(100,+O RIFN,3)) Q :$P(OR3,U, 11)'=1
  1035   "RTN","ORC ACT1",104, 0)
  1036    S ORIG=+$ P(OR3,U,5)  Q:'ORIG   Q:$P($G(^O R(100,ORIG ,3)),U,3)' =12
  1037   "RTN","ORC ACT1",105, 0)
  1038    S ORDA=0  F  S ORDA= $O(^OR(100 ,ORIG,8,OR DA)) Q:ORD A'>0  I '$ P($G(^(ORD A,0)),U,OR FLD) D
  1039   "RTN","ORC ACT1",106, 0)
  1040    . S ORLK= $$LOCK1^OR X2(ORIG) Q :'ORLK
  1041   "RTN","ORC ACT1",107, 0)
  1042    . S ORES( ORIG_";"_O RDA)=""
  1043   "RTN","ORC ACT1",108, 0)
  1044    Q
  1045   "RTN","ORC ACT1",109, 0)
  1046    ;
  1047   "RTN","ORC ACT1",110, 0)
  1048   COMPLX ; - - Ck for o ther child  orders to  be verifi ed at same  time
  1049   "RTN","ORC ACT1",111, 0)
  1050    N IFN,DAD ,CHLD,ALL, P,X,I
  1051   "RTN","ORC ACT1",112, 0)
  1052    S P=$S(OR VER="N":9, ORVER="C": 11,ORVER=" R":19,1:0)  Q:P<1
  1053   "RTN","ORC ACT1",113, 0)
  1054    S IFN=0 F   S IFN=$O (ORES(IFN) ) Q:IFN<1   D
  1055   "RTN","ORC ACT1",114, 0)
  1056    . S X=+$P ($G(^OR(10 0,+IFN,0)) ,U,14) Q:$ $NMSP^ORCD (X)'["PS"
  1057   "RTN","ORC ACT1",115, 0)
  1058    . S X=$P( $G(^OR(100 ,+IFN,8,+$ P(IFN,";", 2),0)),U,2 ) Q:X'="NW "&(X'="XX" )
  1059   "RTN","ORC ACT1",116, 0)
  1060    . I $P($G (^OR(100,+ IFN,3)),U, 9) S DAD(+ $P(^(3),U, 9))=""
  1061   "RTN","ORC ACT1",117, 0)
  1062    Q:'$O(DAD (0))  S IF N=0 F  S I FN=+$O(DAD (IFN)) Q:I FN<1  D
  1063   "RTN","ORC ACT1",118, 0)
  1064    . S CHLD= 0,ALL=1
  1065   "RTN","ORC ACT1",119, 0)
  1066    . F  S CH LD=+$O(^OR (100,IFN,2 ,CHLD)) Q: CHLD<1  F  X="NW","XX " D
  1067   "RTN","ORC ACT1",120, 0)
  1068    .. S I=+$ O(^OR(100, CHLD,8,"C" ,X,0)) Q:I <1
  1069   "RTN","ORC ACT1",121, 0)
  1070    .. Q:$P($ G(^OR(100, CHLD,8,I,0 )),U,P)  Q :$D(ORES(C HLD_";"_I) )
  1071   "RTN","ORC ACT1",122, 0)
  1072    .. S ORES (CHLD_";"_ I)="",ALL= 0
  1073   "RTN","ORC ACT1",123, 0)
  1074    . Q:ALL   S X=$$ORDI TEM^ORCACT (IFN) D SU BHDR^ORCAC T(X)
  1075   "RTN","ORC ACT1",124, 0)
  1076    . W !,"Al l doses of  this comp lex order  must be ve rified tog ether;"
  1077   "RTN","ORC ACT1",125, 0)
  1078    . W !,"ad ding remai ning doses  to signat ure list.. ."
  1079   "RTN","ORC ACT1",126, 0)
  1080    Q
  1081   "RTN","ORC ACT1",127, 0)
  1082    ;
  1083   "RTN","ORC ACT1",128, 0)
  1084   CKALERT ;  -- Ck if U nverified  Orders ale rts can be  deleted
  1085   "RTN","ORC ACT1",129, 0)
  1086    N ORNOW,O RBEG,ORLIS T,ORALL,OR MEDS S ORN OW=$$NOW^X LFDT
  1087   "RTN","ORC ACT1",130, 0)
  1088    S:'$G(ORW ARD) ORBEG =$$FMADD^X LFDT(ORNOW ,"-30") I  $G(ORWARD)  D
  1089   "RTN","ORC ACT1",131, 0)
  1090    . N DFN,V AIN,VAERR  S DFN=+ORV P D INP^VA DPT
  1091   "RTN","ORC ACT1",132, 0)
  1092    . S ORBEG =$S($G(VAI N(7)):$P(V AIN(7),U), 1:$$FMADD^ XLFDT(ORNO W,-30))
  1093   "RTN","ORC ACT1",133, 0)
  1094    D EN^ORQ1 (ORVP,,9,, ORBEG,ORNO W) ;see if  any unver ified orde rs remain
  1095   "RTN","ORC ACT1",134, 0)
  1096    I $G(ORLI ST),$G(^TM P("ORR",$J ,ORLIST,"T OT")) D  ; see if any  are meds
  1097   "RTN","ORC ACT1",135, 0)
  1098    . N ORRX, ORGRP,I,IF N,DG S ORA LL=1
  1099   "RTN","ORC ACT1",136, 0)
  1100    . S ORRX= +$O(^ORD(1 00.98,"B", "RX",0)) D  GRP^ORQ1( ORRX)
  1101   "RTN","ORC ACT1",137, 0)
  1102    . S I=0 F   S I=$O(^ TMP("ORR", $J,ORLIST, I)) Q:I'>0   S IFN=+^ (I),DG=+$P ($G(^OR(10 0,IFN,0)), U,11) I $D (ORGRP(DG) ) S ORMEDS =1 Q
  1103   "RTN","ORC ACT1",138, 0)
  1104    D:'$G(ORA LL) DELALR T("UNVERIF IED ORDER" )
  1105   "RTN","ORC ACT1",139, 0)
  1106    D:'$G(ORM EDS) DELAL RT("UNVERI FIED MEDIC ATION ORDE R")
  1107   "RTN","ORC ACT1",140, 0)
  1108    Q
  1109   "RTN","ORC ACT1",141, 0)
  1110    ;
  1111   "RTN","ORC ACT1",142, 0)
  1112   DELALRT(X)  ; -- dele te alert X
  1113   "RTN","ORC ACT1",143, 0)
  1114    N ORNIFN, XQAKILL,XQ AID
  1115   "RTN","ORC ACT1",144, 0)
  1116    S ORNIFN= +$O(^ORD(1 00.9,"B",X ,0)) Q:ORN IFN'>0
  1117   "RTN","ORC ACT1",145, 0)
  1118    S XQAKILL =$$XQAKILL ^ORB3F1(OR NIFN)
  1119   "RTN","ORC ACT1",146, 0)
  1120    S XQAID=$ P($G(^ORD( 100.9,ORNI FN,0)),U,2 )_","_+ORV P_","_ORNI FN
  1121   "RTN","ORC ACT1",147, 0)
  1122    D DELETEA ^XQALERT
  1123   "RTN","ORC ACT1",148, 0)
  1124    Q
  1125   "RTN","ORC ACT1",149, 0)
  1126    ;
  1127   "RTN","ORC ACT1",150, 0)
  1128   UNLOCK ; - - Unlock o rders in O RES(ORIFN)  [from VR1 ]
  1129   "RTN","ORC ACT1",151, 0)
  1130    F  S ORIF N=$O(ORES( ORIFN)) Q: ORIFN'>0   D UNLK1^OR X2(+ORIFN)
  1131   "RTN","ORC ACT1",152, 0)
  1132    Q
  1133   "RTN","ORC ACT1",153, 0)
  1134    ;
  1135   "RTN","ORC ACT1",154, 0)
  1136   SIGNREQD(I FN) ; -- R eturns 2,  1, or 0, i f order/ac tions need  ES
  1137   "RTN","ORC ACT1",155, 0)
  1138    Q +$P($G( ^OR(100,IF N,0)),U,16 )
  1139   "RTN","ORC ACT1",156, 0)
  1140    ;
  1141   "RTN","ORC ACT1",157, 0)
  1142   SIGN ; --  Sign order s [no long er used]
  1143   "RTN","ORC ACT1",158, 0)
  1144    D EN^ORCS IGN
  1145   "RTN","ORC ACT1",159, 0)
  1146    Q
  1147   "RTN","ORC ACT1",160, 0)
  1148    ;
  1149   "RTN","ORC ACT1",161, 0)
  1150   COMPLETE ;  -- comple te orders
  1151   "RTN","ORC ACT1",162, 0)
  1152    N ORLK,OR I,NMBR,IDX ,ORIFN,ORD ITM,ORES,O RERR,ORSIG ,ORSTOP
  1153   "RTN","ORC ACT1",163, 0)
  1154    I '$G(ORN MBR) S ORN MBR=$$ORDE RS^ORCHART ("complete ") Q:'ORNM BR
  1155   "RTN","ORC ACT1",164, 0)
  1156    D FREEZE^ ORCMENU S  VALMBCK="R " K OREBUI LD
  1157   "RTN","ORC ACT1",165, 0)
  1158    F ORI=1:1 :$L(ORNMBR ) S NMBR=$ P(ORNMBR," ,",ORI) D: NMBR  Q:$D (ORQUIT)
  1159   "RTN","ORC ACT1",166, 0)
  1160    . S IDX=$ G(^TMP("OR ",$J,ORTAB ,"IDX",NMB R)),ORIFN= $P(IDX,U)
  1161   "RTN","ORC ACT1",167, 0)
  1162    . Q:'ORIF N  S:'$P(O RIFN,";",2 ) ORIFN=+O RIFN_";1"
  1163   "RTN","ORC ACT1",168, 0)
  1164    . I '$$VA LID^ORCACT 0(ORIFN,"C P",.ORERR)  W !!,$$OR DITEM^ORCA CT(ORIFN)_ " invalid. ",!,"  >>  "_ORERR H  1 Q
  1165   "RTN","ORC ACT1",169, 0)
  1166    . S ORLK= $$LOCK1^OR X2(+ORIFN)  I 'ORLK W  !!,$$ORDI TEM^ORCACT (ORIFN)_"  invalid.", !,"  >> "_ $P(ORLK,U, 2) H 1 Q
  1167   "RTN","ORC ACT1",170, 0)
  1168    . S ORES( ORIFN)=""
  1169   "RTN","ORC ACT1",171, 0)
  1170   CP1 Q:'$O( ORES(0))   S ORSIG=$S ($$ESIG^OR CSIGN:1,1: 0)
  1171   "RTN","ORC ACT1",172, 0)
  1172    I 'ORSIG  W !,"Nothi ng complet ed!" D UNL OCK H 1 Q
  1173   "RTN","ORC ACT1",173, 0)
  1174    W !!,"Com pleting or ders ..."  S ORSTOP=+ $E($$NOW^X LFDT,1,12) ,ORIFN=0
  1175   "RTN","ORC ACT1",174, 0)
  1176    F  S ORIF N=$O(ORES( ORIFN)) Q: ORIFN'>0   D
  1177   "RTN","ORC ACT1",175, 0)
  1178    . D COMP^ ORCSAVE2(O RIFN,DUZ,O RSTOP),UNL K1^ORX2(+O RIFN)
  1179   "RTN","ORC ACT1",176, 0)
  1180    . D COMP^ ORMBLDOR(O RIFN)
  1181   "RTN","ORC ACT1",177, 0)
  1182    S OREBUIL D=1
  1183   "RTN","ORC ACT1",178, 0)
  1184   CPQ Q
  1185   "RTN","ORC SEND")
  1186   0^2^B65938 879
  1187   "RTN","ORC SEND",1,0)
  1188   ORCSEND ;S LC/MKB-Rel ease order s ; 11/8/2 006
  1189   "RTN","ORC SEND",2,0)
  1190    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**4 ,27,45,79, 92,141,165 ,195,228,2 43,303,296 ,390**;Dec  17, 1997; Build 110
  1191   "RTN","ORC SEND",3,0)
  1192    ;
  1193   "RTN","ORC SEND",4,0)
  1194   EN(ORIFN,A CTION,SIGS TS,RELSTS, NATURE,REA SON,ORERR)  ; -- Rele ase [actio ns on] ord ers
  1195   "RTN","ORC SEND",5,0)
  1196    N ORDA,OR NOW,SIGNRE QD,SIGNED, SIGNER
  1197   "RTN","ORC SEND",6,0)
  1198    S SIGNREQ D=+$P($G(^ OR(100,+OR IFN,0)),U, 16),ORERR= ""
  1199   "RTN","ORC SEND",7,0)
  1200    S SIGNED= $S(SIGSTS= 2:0,1:1),S IGNER=$S(S IGSTS=1:DU Z,SIGSTS=7 :DUZ,1:"")
  1201   "RTN","ORC SEND",8,0)
  1202    S ORDA=+$ P(ORIFN,"; ",2),ORIFN =+ORIFN,OR NOW=+$E($$ NOW^XLFDT, 1,12)
  1203   "RTN","ORC SEND",9,0)
  1204    S:"ES"[$G (ACTION) A CTION=$P($ G(^OR(100, ORIFN,8,OR DA,0)),U,2 )
  1205   "RTN","ORC SEND",10,0 )
  1206    I SIGNREQ D,ORDA,"^N W^RW^XX^RN ^DC^HD^RL^ "[(U_ACTIO N_U) D  ;  sign/alert
  1207   "RTN","ORC SEND",11,0 )
  1208    . I 'SIGN ED D NOTIF ^ORCSIGN Q
  1209   "RTN","ORC SEND",12,0 )
  1210    . D:SIGST S'="" SIGN ^ORCSAVE2( ORIFN,SIGN ER,ORNOW,S IGSTS,ORDA )
  1211   "RTN","ORC SEND",13,0 )
  1212    . D:SIGST S=4 CHART^ ORCSIGN ;  not used a nymore
  1213   "RTN","ORC SEND",14,0 )
  1214    I '$L(ACT ION) S ORE RR="1^Inva lid order  action" Q
  1215   "RTN","ORC SEND",15,0 )
  1216    I $$READY (ORIFN,ORD A) D:$L($T (@ACTION))  @ACTION I  'ORERR,AC TION="NW"  D
  1217   "RTN","ORC SEND",16,0 )
  1218    . N OREVT  S OREVT=+ $P($G(^OR( 100,ORIFN, 0)),U,17)  Q:OREVT<1
  1219   "RTN","ORC SEND",17,0 )
  1220    . I '$$EV TORDER^ORE VNTX(ORIFN ) D SAVE^O RMEVNT1(OR IFN,OREVT, 2,"ES")
  1221   "RTN","ORC SEND",18,0 )
  1222    ; If orde r originat ed from th e back doo r, send Dx  and TxF b ack to anc il.
  1223   "RTN","ORC SEND",19,0 )
  1224    I SIGNED, $P($G(^OR( 100,+ORIFN ,3)),U,11) ="P" D BDO EDIT^ORWDB A7
  1225   "RTN","ORC SEND",20,0 )
  1226    Q
  1227   "RTN","ORC SEND",21,0 )
  1228    ;
  1229   "RTN","ORC SEND",22,0 )
  1230   EN1(ORDER, ORERR) ; - - Delayed  Release [f rom RELEAS E^ORMEVNT]
  1231   "RTN","ORC SEND",23,0 )
  1232    ;
  1233   "RTN","ORC SEND",24,0 )
  1234    Q:$P($G(^ OR(100,+OR DER,3)),U, 3)'=10
  1235   "RTN","ORC SEND",25,0 )
  1236    N ORPKG,O RA0,ORNOW, ORIFN,ORDA ,ORNP,ORNA TR,ORQUIT, ORDUZ,SIGS TS,RELSTS
  1237   "RTN","ORC SEND",26,0 )
  1238    S ORPKG=$ P($G(^OR(1 00,+ORDER, 0)),U,14), ORA0=$G(^( 8,1,0))
  1239   "RTN","ORC SEND",27,0 )
  1240    S ORNOW=+ $E($$NOW^X LFDT,1,12) ,ORIFN=+OR DER,ORDA=1 ,ORNP=$P(O RA0,U,3)
  1241   "RTN","ORC SEND",28,0 )
  1242    S SIGSTS= $P(ORA0,U, 4),ORNATR= $P($G(^ORD (100.02,+$ P(ORA0,U,1 2),0)),U,2 )
  1243   "RTN","ORC SEND",29,0 )
  1244    S RELSTS= $S(SIGSTS' =2:1,"^V^P ^"[(U_ORNA TR_U):1,1: 0)
  1245   "RTN","ORC SEND",30,0 )
  1246    I RELSTS  D
  1247   "RTN","ORC SEND",31,0 )
  1248    . D START DT^ORCSAVE 2(ORIFN),P KGSTUFF^OR CSEND1(ORP KG) Q:$G(O RQUIT)
  1249   "RTN","ORC SEND",32,0 )
  1250    . S ORDUZ =$S(SIGSTS =0:$P(ORA0 ,U,7),SIGS TS=1:$P(OR A0,U,5),SI GSTS=2:$P( ORA0,U,17) ,SIGSTS=3: $P(ORA0,U, 13),1:DUZ)
  1251   "RTN","ORC SEND",33,0 )
  1252    . D EDO1^ ORWPFSS1   ;PFSS Even t Delayed  Orders
  1253   "RTN","ORC SEND",34,0 )
  1254    . D RELEA SE^ORCSAVE 2(ORIFN,OR DA,ORNOW,O RDUZ),NEW^ ORMBLD(ORI FN)
  1255   "RTN","ORC SEND",35,0 )
  1256    . I "^10^ 13^"[(U_$P ($G(^OR(10 0,ORIFN,3) ),U,3)_U)  S ORERR=1  ;error
  1257   "RTN","ORC SEND",36,0 )
  1258    I 'RELSTS !$G(ORERR) ,$P($G(^OR (100,ORIFN ,3)),U,3)= 10 D STATU S^ORCSAVE2 (ORIFN,11)  S $P(^OR( 100,ORIFN, 8,1,0),U,1 5)=11
  1259   "RTN","ORC SEND",37,0 )
  1260    Q
  1261   "RTN","ORC SEND",38,0 )
  1262    ;
  1263   "RTN","ORC SEND",39,0 )
  1264   EN2(ORIFN, SIGSTS,NAT URE,ORERR)  ; -- Manu al Release  [from ORE VNT1,SENDE D^ORWDX]
  1265   "RTN","ORC SEND",40,0 )
  1266    N ORDA,OR NOW,OREVT, ORA0,ORNP, SIGNREQD,S IGNED,RELS TS
  1267   "RTN","ORC SEND",41,0 )
  1268    S ORDA=+$ P(ORIFN,"; ",2),ORIFN =+ORIFN S: ORDA<1 ORD A=1
  1269   "RTN","ORC SEND",42,0 )
  1270    S OREVT=+ $P($G(^OR( 100,ORIFN, 0)),U,17), ORA0=$G(^( 8,ORDA,0))
  1271   "RTN","ORC SEND",43,0 )
  1272    S ORNP=$P (ORA0,U,3) ,SIGNREQD= ($P(ORA0,U ,4)'=3),(S IGNED,RELS TS)=1
  1273   "RTN","ORC SEND",44,0 )
  1274    S ORNOW=+ $E($$NOW^X LFDT,1,12) ,ORERR=""
  1275   "RTN","ORC SEND",45,0 )
  1276    I $P(ORA0 ,U,4)=2 D   ;needs ES
  1277   "RTN","ORC SEND",46,0 )
  1278    . N SIGNE R S SIGNER =$S(SIGSTS =1:DUZ,1:" ")
  1279   "RTN","ORC SEND",47,0 )
  1280    . I SIGST S=2 D NOTI F^ORCSIGN  S SIGNED=0  Q  ;still  unsigned
  1281   "RTN","ORC SEND",48,0 )
  1282    . D:SIGST S'="" SIGN ^ORCSAVE2( ORIFN,SIGN ER,ORNOW,S IGSTS,ORDA )
  1283   "RTN","ORC SEND",49,0 )
  1284    D EDO2^OR WPFSS1  ;P FSS Event  Delayed Or ders
  1285   "RTN","ORC SEND",50,0 )
  1286    D NW I 'O RERR D SAV E^ORMEVNT1 (+ORIFN,OR EVT,2,"MN" )
  1287   "RTN","ORC SEND",51,0 )
  1288    Q
  1289   "RTN","ORC SEND",52,0 )
  1290    ;
  1291   "RTN","ORC SEND",53,0 )
  1292   NW ; -- Ne w order OR IFN
  1293   "RTN","ORC SEND",54,0 )
  1294   RW ; -- Re written or der ORIFN
  1295   "RTN","ORC SEND",55,0 )
  1296   XX ; -- Ch anged orde r ORIFN
  1297   "RTN","ORC SEND",56,0 )
  1298   RN ; -- Re newed orde r ORIFN
  1299   "RTN","ORC SEND",57,0 )
  1300    N ORQUIT, STS,TYPE,O R0,OR3,COD E,ORIG,ORS AVE
  1301   "RTN","ORC SEND",58,0 )
  1302    N IVDIEN, IVPKGM
  1303   "RTN","ORC SEND",59,0 )
  1304    S IVPKGM= 0
  1305   "RTN","ORC SEND",60,0 )
  1306    S IVDIEN= $O(^ORD(10 1.41,"B"," PSJI OR PA T FLUID OE ",""))
  1307   "RTN","ORC SEND",61,0 )
  1308    I SIGNREQ D,'SIGNED, 'RELSTS S  ORERR=$$NE EDSIG,OREB UILD=1 Q
  1309   "RTN","ORC SEND",62,0 )
  1310    S:'ORDA O RDA=1 S OR SAVE=ORIFN
  1311   "RTN","ORC SEND",63,0 )
  1312    S OR0=$G( ^OR(100,OR IFN,0)),OR 3=$G(^(3))  D STARTDT ^ORCSAVE2( ORIFN)
  1313   "RTN","ORC SEND",64,0 )
  1314    S TYPE=$P (OR3,U,11) ,ORIG=+$P( OR3,U,5),C ODE="NW"
  1315   "RTN","ORC SEND",65,0 )
  1316    I TYPE=1, ORIG,$D(^O R(100,ORIG ,4)) S COD E="XO",^OR (100,ORIG, 6)=$O(^ORD (100.02,"C ","C",0))_ U_DUZ_U_OR NOW
  1317   "RTN","ORC SEND",66,0 )
  1318    I $$GET1^ DIQ(9.4,+$ P(OR0,U,14 )_",",1)=" PSJ" S IVP KGM=1
  1319   "RTN","ORC SEND",67,0 )
  1320    I IVPKGM= 1,$P($P(OR 0,U,5),";" )=IVDIEN D  PSJI^ORCS END3 Q:$G( ORQUIT)
  1321   "RTN","ORC SEND",68,0 )
  1322    I IVPKGM= 0!($P($P(O R0,U,5),"; ")'=IVDIEN ) D PKGSTU FF^ORCSEND 1(+$P(OR0, U,14)) Q:$ G(ORQUIT)
  1323   "RTN","ORC SEND",69,0 )
  1324    D RELEASE ^ORCSAVE2( ORIFN,ORDA ,ORNOW,DUZ ,$G(NATURE ))
  1325   "RTN","ORC SEND",70,0 )
  1326    D NEW^ORM BLD(ORIFN, CODE) S OR IFN=ORSAVE ,STS=$P($G (^OR(100,O RIFN,3)),U ,3)
  1327   "RTN","ORC SEND",71,0 )
  1328    I (STS=1) !(STS=13)  S ORERR="1 ^"_$$WHY(O RIFN,1) D: 'SIGNED&SI GNREQD NOS IG K:ORIG  ^OR(100,OR IG,6)
  1329   "RTN","ORC SEND",72,0 )
  1330    I STS=11  S ORERR="1 ^ERROR"
  1331   "RTN","ORC SEND",73,0 )
  1332    Q
  1333   "RTN","ORC SEND",74,0 )
  1334    ;
  1335   "RTN","ORC SEND",75,0 )
  1336   DC ; -- DC  order ORI FN
  1337   "RTN","ORC SEND",76,0 )
  1338    N PKG,COD E,ORCHLD,O RCHDA,STS, ORIDA,ORSA VE,OR3,OR6 ,DCNATURE
  1339   "RTN","ORC SEND",77,0 )
  1340    I '$G(REA SON),$G(NA TURE)="D"  S REASON=+ $O(^ORD(10 0.03,"C"," ORDUP",0))
  1341   "RTN","ORC SEND",78,0 )
  1342    S:$G(REAS ON) $P(^OR (100,ORIFN ,6),U,1,5) =$S($G(NAT URE):NATUR E,$L($G(NA TURE)):$O( ^ORD(100.0 2,"C",NATU RE,0)),1:" ")_"^^^"_+ REASON_U_$ P(^ORD(100 .03,+REASO N,0),U)
  1343   "RTN","ORC SEND",79,0 )
  1344    I SIGNREQ D,'SIGNED, 'RELSTS S  ORERR=$$NE EDSIG Q
  1345   "RTN","ORC SEND",80,0 )
  1346    S $P(^OR( 100,ORIFN, 6),U,2,3)= $S($G(DGPM T):"",1:DU Z)_U_ORNOW ,ORSAVE=OR IFN S:'$G( REASON) RE ASON=$P(^( 6),U,4)
  1347   "RTN","ORC SEND",81,0 )
  1348    S STS=$P( $G(^OR(100 ,ORIFN,3)) ,U,3),PKG= $P($G(^(0) ),U,14),PK G=$$NMSP^O RCD(PKG),C ODE=$S(PKG ="LR":"CA" ,(PKG="PS" )&(STS=5): "CA",(PKG= "FH")&(STS =8):"CA",1 :"DC")
  1349   "RTN","ORC SEND",82,0 )
  1350    D:ORDA RE LEASE^ORCS AVE2(ORIFN ,ORDA,ORNO W,DUZ,$G(N ATURE))
  1351   "RTN","ORC SEND",83,0 )
  1352   DC1 I $O(^ OR(100,ORI FN,2,0)) D   G DC2 ;  DC childre n
  1353   "RTN","ORC SEND",84,0 )
  1354    . S ORCHL D=0 F  S O RCHLD=$O(^ OR(100,ORI FN,2,ORCHL D)) Q:ORCH LD'>0  I $ $VALID^ORC ACT0(ORCHL D,"DC") D   Q:$G(ORER R)
  1355   "RTN","ORC SEND",85,0 )
  1356    . . S ORC HDA=$S(ORD A:$$ACTION ^ORCSAVE(" DC",ORCHLD ,ORNP),1:0 )
  1357   "RTN","ORC SEND",86,0 )
  1358    . . D:ORC HDA SIGN^O RCSAVE2(OR CHLD,,,8,O RCHDA) ;Si g on Paren t only
  1359   "RTN","ORC SEND",87,0 )
  1360    . . D MSG ^ORMBLD((O RCHLD_";"_ ORCHDA),CO DE,$G(REAS ON))
  1361   "RTN","ORC SEND",88,0 )
  1362    . . I "^1 ^13^"'[(U_ $P(^OR(100 ,ORCHLD,3) ,U,3)_U) S  ORERR="1^ "_$$WHY(OR CHLD,ORCHD A)
  1363   "RTN","ORC SEND",89,0 )
  1364    . ;D:'$G( ORERR) STA TUS^ORCSAV E2(ORIFN,1 )
  1365   "RTN","ORC SEND",90,0 )
  1366    . S:$G(OR ERR) ^OR(1 00,ORIFN,8 ,ORDA,1)=$ P(ORERR,U, 2)
  1367   "RTN","ORC SEND",91,0 )
  1368    D MSG^ORM BLD((ORIFN _";"_ORDA) ,CODE,$G(R EASON))
  1369   "RTN","ORC SEND",92,0 )
  1370   DC2 S ORIF N=ORSAVE,O R3=$G(^OR( 100,ORIFN, 3)),STS=$P (OR3,U,3)
  1371   "RTN","ORC SEND",93,0 )
  1372    S OR6=$G( ^OR(100,OR IFN,6))
  1373   "RTN","ORC SEND",94,0 )
  1374    I STS'=1, STS'=13,ST S'=2 D  Q
  1375   "RTN","ORC SEND",95,0 )
  1376    . S ORERR ="1^"_$S(O RDA:$$WHY( ORIFN,ORDA ),1:"Unabl e to disco ntinue")
  1377   "RTN","ORC SEND",96,0 )
  1378    . I ORDA, 'SIGNED&SI GNREQD D N OSIG ; sig  no longer  reqd
  1379   "RTN","ORC SEND",97,0 )
  1380    . K ^OR(1 00,ORIFN,6 )
  1381   "RTN","ORC SEND",98,0 )
  1382    S DCNATUR E=$S(+OR6: +OR6,1:$G( NATURE))
  1383   "RTN","ORC SEND",99,0 )
  1384    S $P(^OR( 100,ORIFN, 3),U,7)=$S ('$$ACTV^O RX1($G(DCN ATURE)):0, ORDA:ORDA, 1:$P(OR3,U ,7))
  1385   "RTN","ORC SEND",100, 0)
  1386    D CANCEL( ORIFN),SET ALL^ORDD10 0(ORIFN)
  1387   "RTN","ORC SEND",101, 0)
  1388    I $P(OR3, U,11)=2 D   ; dc a re newal
  1389   "RTN","ORC SEND",102, 0)
  1390    . N ORIG, ORIG3,NATR  S ORIG=$P (OR3,U,5), ORIG3=$G(^ OR(100,ORI G,3)) Q:'O RIG
  1391   "RTN","ORC SEND",103, 0)
  1392    . ;I CODE ="CA",+$P( OR6,U,9)'> 0 S $P(^OR (100,ORIG, 3),U,6)=""  Q  ;pend  - remove f wd ptr
  1393   "RTN","ORC SEND",104, 0)
  1394    . I +$P(O R6,U,9)'>0  S $P(^OR( 100,ORIG,3 ),U,6)=""  Q  ;pend -  remove fw d ptr
  1395   "RTN","ORC SEND",105, 0)
  1396    . Q:"^1^7 ^12^13^"[( U_$P(ORIG3 ,U,3)_U)   S NATR=$O( ^ORD(100.0 2,"C","A", 0))
  1397   "RTN","ORC SEND",106, 0)
  1398    . S ^OR(1 00,ORIG,6) =NATR_U_DU Z_U_ORNOW_ "^^Renewal  cancelled "
  1399   "RTN","ORC SEND",107, 0)
  1400    . D MSG^O RMBLD(ORIG ,"DC") I " ^1^13^"'[$ P(^OR(100, ORIG,3),U, 3) K ^(6)  Q
  1401   "RTN","ORC SEND",108, 0)
  1402    . S:'$$AC TV^ORX1(NA TR) $P(^OR (100,ORIG, 3),U,7)=0
  1403   "RTN","ORC SEND",109, 0)
  1404    Q
  1405   "RTN","ORC SEND",110, 0)
  1406    ;
  1407   "RTN","ORC SEND",111, 0)
  1408   CANCEL(IFN ) ; -- Can cel any ou tstanding  actions fo r order IF
  1409   "RTN","ORC SEND",112, 0)
  1410    N I S I=0
  1411   "RTN","ORC SEND",113, 0)
  1412    F  S I=$O (^OR(100,I FN,8,I)) Q :I'>0  I $ P(^(I,0),U ,15)=11 S  $P(^(0),U, 15)=13 D:$ P(^(0),U,4 )=2 SIGN^O RCSAVE2(IF N,"","",5, I) ; cance lled, sig  not reqd n ow
  1413   "RTN","ORC SEND",114, 0)
  1414    Q
  1415   "RTN","ORC SEND",115, 0)
  1416    ;
  1417   "RTN","ORC SEND",116, 0)
  1418   HD ; -- Ho ld order O RIFN
  1419   "RTN","ORC SEND",117, 0)
  1420    N STS,ORS AVE I 'ORD A S ORERR= "1^Unable  to hold" Q
  1421   "RTN","ORC SEND",118, 0)
  1422    I SIGNREQ D,'SIGNED, 'RELSTS S  ORERR=$$NE EDSIG Q
  1423   "RTN","ORC SEND",119, 0)
  1424    D RELEASE ^ORCSAVE2( ORIFN,ORDA ,ORNOW,DUZ ,$G(NATURE ))
  1425   "RTN","ORC SEND",120, 0)
  1426    S ORSAVE= ORIFN D MS G^ORMBLD(( ORIFN_";"_ ORDA),"HD" ) S ORIFN= ORSAVE
  1427   "RTN","ORC SEND",121, 0)
  1428    S STS=$P( $G(^OR(100 ,ORIFN,3)) ,U,3) I ST S=3 S $P(^ (3),U,7)=O RDA D SET^ ORDD100(OR IFN,ORDA)
  1429   "RTN","ORC SEND",122, 0)
  1430    I STS'=3  S ORERR="1 ^"_$$WHY(O RIFN,ORDA)  D:'SIGNED &SIGNREQD  NOSIG
  1431   "RTN","ORC SEND",123, 0)
  1432    Q
  1433   "RTN","ORC SEND",124, 0)
  1434    ;
  1435   "RTN","ORC SEND",125, 0)
  1436   RL ; -- Re lease hold  on order  ORIFN
  1437   "RTN","ORC SEND",126, 0)
  1438    N STS,ORS AVE,ORHD I  'ORDA S O RERR="1^Un able to re lease hold " Q
  1439   "RTN","ORC SEND",127, 0)
  1440    I SIGNREQ D,'SIGNED, 'RELSTS S  ORERR=$$NE EDSIG Q
  1441   "RTN","ORC SEND",128, 0)
  1442    D RELEASE ^ORCSAVE2( ORIFN,ORDA ,ORNOW,DUZ ,$G(NATURE ))
  1443   "RTN","ORC SEND",129, 0)
  1444    S ORSAVE= ORIFN D MS G^ORMBLD(( ORIFN_";"_ ORDA),"RL" ) S ORIFN= ORSAVE
  1445   "RTN","ORC SEND",130, 0)
  1446    S STS=$P( $G(^OR(100 ,ORIFN,3)) ,U,3),ORHD =+$P($G(^( 3)),U,7)
  1447   "RTN","ORC SEND",131, 0)
  1448    I STS'=3  S $P(^OR(1 00,ORIFN,3 ),U,7)=ORD A,$P(^(8,O RHD,2),U,1 ,2)=ORNOW_ U_DUZ D SE T^ORDD100( ORIFN,ORDA )
  1449   "RTN","ORC SEND",132, 0)
  1450    I STS=3 S  ORERR="1^ "_$$WHY(OR IFN,ORDA)  D:'SIGNED& SIGNREQD N OSIG
  1451   "RTN","ORC SEND",133, 0)
  1452    Q
  1453   "RTN","ORC SEND",134, 0)
  1454    ;
  1455   "RTN","ORC SEND",135, 0)
  1456   FL ; -- Fl ag order O RIFN
  1457   "RTN","ORC SEND",136, 0)
  1458    Q
  1459   "RTN","ORC SEND",137, 0)
  1460    ;
  1461   "RTN","ORC SEND",138, 0)
  1462   UF ; -- Un flag order  ORIFN
  1463   "RTN","ORC SEND",139, 0)
  1464    Q
  1465   "RTN","ORC SEND",140, 0)
  1466    ;
  1467   "RTN","ORC SEND",141, 0)
  1468   CM ; -- Ad d Ward com ments to o rder ORIFN
  1469   "RTN","ORC SEND",142, 0)
  1470    Q
  1471   "RTN","ORC SEND",143, 0)
  1472    ;
  1473   "RTN","ORC SEND",144, 0)
  1474   VR ; -- Ve rify order  ORIFN
  1475   "RTN","ORC SEND",145, 0)
  1476    I 'ORDA!( SIGSTS=2)  S ORERR="1 ^Unable to  verify" Q
  1477   "RTN","ORC SEND",146, 0)
  1478    I "^N^C^R ^"'[(U_$G( ORVER)_U)  S ORERR="1 ^Unable to  verify" Q
  1479   "RTN","ORC SEND",147, 0)
  1480    D VERIFY^ ORCSAVE2(O RIFN,ORDA, ORVER,DUZ, ORNOW)
  1481   "RTN","ORC SEND",148, 0)
  1482    ; -- send  HL7 msg t o Pharmacy  if Nurse- Verified,  [Sts=pendi ng]
  1483   "RTN","ORC SEND",149, 0)
  1484    Q:ORVER'= "N"  N ORS TS,ORPKG,O RX
  1485   "RTN","ORC SEND",150, 0)
  1486    S ORX=$P( $G(^OR(100 ,ORIFN,8,O RDA,0)),U, 2) Q:ORX'= "NW"&(ORX' ="XX")
  1487   "RTN","ORC SEND",151, 0)
  1488    S ORPKG=+ $P($G(^OR( 100,ORIFN, 0)),U,14), ORSTS=$P($ G(^(3)),U, 3)
  1489   "RTN","ORC SEND",152, 0)
  1490    ;I ORSTS= 5!$L($T(ZV ^ORMPS)),$ $NMSP^ORCD (ORPKG)="P S" D VER^O RMBLDPS(OR IFN)
  1491   "RTN","ORC SEND",153, 0)
  1492    I $$NMSP^ ORCD(ORPKG )="PS" D V ER^ORMBLDP S(ORIFN) Q
  1493   "RTN","ORC SEND",154, 0)
  1494    D VER^ORM BLDOR(ORIF N)
  1495   "RTN","ORC SEND",155, 0)
  1496    Q
  1497   "RTN","ORC SEND",156, 0)
  1498    ;
  1499   "RTN","ORC SEND",157, 0)
  1500   NEEDSIG()  ; -- Msg
  1501   "RTN","ORC SEND",158, 0)
  1502    Q "1^This  order req uires a si gnature."
  1503   "RTN","ORC SEND",159, 0)
  1504    ;
  1505   "RTN","ORC SEND",160, 0)
  1506   WHY(IFN,DA ) ; -- Ret urn reason  request w as rejecte d
  1507   "RTN","ORC SEND",161, 0)
  1508    N X S X=$ G(^OR(100, IFN,8,DA,1 ))
  1509   "RTN","ORC SEND",162, 0)
  1510    S:'$L(X)  X="Unable  to "_$S(AC TION="HD": "hold",ACT ION="RL":" release ho ld",ACTION ="DC":"dis continue", ACTION="XX ":"change" ,ACTION="R N":"renew" ,1:"releas e")
  1511   "RTN","ORC SEND",163, 0)
  1512    Q X
  1513   "RTN","ORC SEND",164, 0)
  1514    ;
  1515   "RTN","ORC SEND",165, 0)
  1516   NOSIG ; --  Mark orde r as Sig n ot Req'd d ue to canc el/reject
  1517   "RTN","ORC SEND",166, 0)
  1518    D SIGN^OR CSAVE2(ORI FN,"","",5 ,ORDA) S S IGNREQD=0
  1519   "RTN","ORC SEND",167, 0)
  1520    Q
  1521   "RTN","ORC SEND",168, 0)
  1522    ;
  1523   "RTN","ORC SEND",169, 0)
  1524   READY(IFN, ACT) ; --  Ready to r elease?
  1525   "RTN","ORC SEND",170, 0)
  1526    N X,Y,OR0 ,OR3,ORA
  1527   "RTN","ORC SEND",171, 0)
  1528    I ACTION= "VR" S Y=1  G RQ ; no  action to  release
  1529   "RTN","ORC SEND",172, 0)
  1530    I 'ACT,AC TION="DC"  S Y=1 G RQ  ; cancel  a duplicat e
  1531   "RTN","ORC SEND",173, 0)
  1532    S Y=0,OR0 =$G(^OR(10 0,IFN,0)), OR3=$G(^(3 )),ORA=$G( ^(8,ACT,0) )
  1533   "RTN","ORC SEND",174, 0)
  1534    I $P(ORA, U,15)=11 S  Y=1 G RQ  ; unreleas ed
  1535   "RTN","ORC SEND",175, 0)
  1536    I $P(ORA, U,15)=10 D   G RQ ; d elayed
  1537   "RTN","ORC SEND",176, 0)
  1538    . I $G(^D PT(+ORVP,. 105)),$$GE T1^DIQ(9.4 ,+$P(OR0,U ,14)_",",1 )="PSO" S  Y=1 Q
  1539   "RTN","ORC SEND",177, 0)
  1540    . Q:'RELS TS  N ORIG  S ORIG=+$ P(OR3,U,5)
  1541   "RTN","ORC SEND",178, 0)
  1542    . I 'SIGN ED,$L($G(N ATURE)) S  $P(ORA,U,1 7)=DUZ,$P( ORA,U,12)= $S(NATURE: NATURE,1:+ $O(^ORD(10 0.02,"C",N ATURE,0))) ,^OR(100,I FN,8,ACT,0 )=ORA
  1543   "RTN","ORC SEND",179, 0)
  1544    . Q:$P(OR 3,U,11)'=1 !('ORIG)   ;dc origin al if sign ed edit
  1545   "RTN","ORC SEND",180, 0)
  1546    . D STATU S^ORCSAVE2 (ORIG,12)
  1547   "RTN","ORC SEND",181, 0)
  1548    . S ^OR(1 00,ORIG,6) =+$O(^ORD( 100.02,"C" ,"C",0))_U _DUZ_U_ORN OW
  1549   "RTN","ORC SEND",182, 0)
  1550    . S $P(^O R(100,ORIG ,3),U,7)=0 ,$P(^(8,1, 0),U,15)=1 2 D:$P($G( ^(0)),U,4) =2 SIGN^OR CSAVE2(ORI G,,,5,1)
  1551   "RTN","ORC SEND",183, 0)
  1552    I $P(OR3, U,3)=11,$P (ORA,U,2)= "NW" S Y=1  ; Action  Sts = "" ( old)
  1553   "RTN","ORC SEND",184, 0)
  1554   RQ I +$$SW STAT^IBBAP I() D:Y=1  EN^ORWPFSS 4(+IFN) ;  Associate  PFSS Accou nt Referen ce with or der, Patch  OR*3.0*22 8 IA #4663
  1555   "RTN","ORC SEND",185, 0)
  1556    Q Y
  1557   "RTN","ORM BLDOR")
  1558   0^3^B56503 60
  1559   "RTN","ORM BLDOR",1,0 )
  1560   ORMBLDOR ;  SLC/MKB -  Build out going OR m sgs ;11/17 /00  11:11
  1561   "RTN","ORM BLDOR",2,0 )
  1562    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**9 7,390**;De c 17, 1997 ;Build 110
  1563   "RTN","ORM BLDOR",3,0 )
  1564   EN ; -- Ge neric orde rs: Activi ty, Nursin g, Diagnos is, Condit ion, Vital s
  1565   "RTN","ORM BLDOR",4,0 )
  1566    N OI,STAR T,STOP,SCH ,TXT
  1567   "RTN","ORM BLDOR",5,0 )
  1568    S OI=$G(O RDIALOG($$ PTR("ORDER ABLE ITEM" ),1))
  1569   "RTN","ORM BLDOR",6,0 )
  1570    S TXT=$G( ORDIALOG($ $PTR("FREE  TEXT 1"), 1))
  1571   "RTN","ORM BLDOR",7,0 )
  1572    S START=$ P(OR0,U,8) ,STOP=$P(O R0,U,9),SC H=""
  1573   "RTN","ORM BLDOR",8,0 )
  1574    S:ORDG=$O (^ORD(100. 98,"B","V/ M",0)) SCH =$$VALUE^O RCSAVE2(IF N,"SCHEDUL E")
  1575   "RTN","ORM BLDOR",9,0 )
  1576    S $P(ORMS G(4),"|",8 )=U_SCH_"^ ^"_$$HL7DA TE(START)_ U_$$HL7DAT E(STOP) ;  QT
  1577   "RTN","ORM BLDOR",10, 0)
  1578    S ORMSG(5 )="OBR|||| "_$$USID^O RMBLD(OI)
  1579   "RTN","ORM BLDOR",11, 0)
  1580    S:$L(TXT)  ORMSG(6)= "NTE|1|L|" _TXT ; ord er text?
  1581   "RTN","ORM BLDOR",12, 0)
  1582    Q
  1583   "RTN","ORM BLDOR",13, 0)
  1584    ;
  1585   "RTN","ORM BLDOR",14, 0)
  1586   ADT ; -- M .A.S. even t requests
  1587   "RTN","ORM BLDOR",15, 0)
  1588    Q  N PROV ,PROV1,ORI FN
  1589   "RTN","ORM BLDOR",16, 0)
  1590    S PROV=+$ G(ORDIALOG ($$PTR("PR OVIDER"),1 )) I 'PROV  D EN Q
  1591   "RTN","ORM BLDOR",17, 0)
  1592    S PROV1=+ $G(ORDIALO G($$PTR("P ROVIDER 1" ),1)),PKG= "DGPM"
  1593   "RTN","ORM BLDOR",18, 0)
  1594    S $P(ORMS G(1),"|",5 )="M.A.S." ,$P(ORMSG( 1),"|",9)= "ADT"
  1595   "RTN","ORM BLDOR",19, 0)
  1596    K ORMSG(4 ) S ORMSG( 4)=ORMSG(3 ),ORMSG(3) =ORMSG(2)
  1597   "RTN","ORM BLDOR",20, 0)
  1598    S ORMSG(2 )="EVN|A08 |"_$$HL7DA TE($$NOW^X LFDT)
  1599   "RTN","ORM BLDOR",21, 0)
  1600    S $P(ORMS G(4),"|",8 )=PROV
  1601   "RTN","ORM BLDOR",22, 0)
  1602    S:PROV1 O RMSG(5)="Z DG|"_PROV1
  1603   "RTN","ORM BLDOR",23, 0)
  1604    S ORIFN=+ IFN D NW^O RMORG ; se t status,  start date
  1605   "RTN","ORM BLDOR",24, 0)
  1606    Q
  1607   "RTN","ORM BLDOR",25, 0)
  1608    ;
  1609   "RTN","ORM BLDOR",26, 0)
  1610   PTR(X) ; - - Returns  ptr value  of prompt  X in #101. 41
  1611   "RTN","ORM BLDOR",27, 0)
  1612    Q +$O(^OR D(101.41," AB",$E("OR  GTX "_X,1 ,63),0))
  1613   "RTN","ORM BLDOR",28, 0)
  1614    ;
  1615   "RTN","ORM BLDOR",29, 0)
  1616   HL7DATE(D)  ; -- FM-> HL7 format
  1617   "RTN","ORM BLDOR",30, 0)
  1618    Q $$FMTHL 7^XLFDT(D)   ;**97
  1619   "RTN","ORM BLDOR",31, 0)
  1620    ;
  1621   "RTN","ORM BLDOR",32, 0)
  1622   COMP(IFN)  ; -- send  message fo r complete d orders
  1623   "RTN","ORM BLDOR",33, 0)
  1624    N OR0,ORM SG S OR0=$ G(^OR(100, +IFN,0))
  1625   "RTN","ORM BLDOR",34, 0)
  1626    S ORMSG(1 )=$$MSH^OR MBLD("ORM" ,"OR"),ORM SG(2)=$$PI D^ORMBLD($ P(OR0,U,2) )
  1627   "RTN","ORM BLDOR",35, 0)
  1628    S ORMSG(3 )=$$PV1^OR MBLD($P(OR 0,U,2),$P( OR0,U,12), +$P(OR0,U, 10))
  1629   "RTN","ORM BLDOR",36, 0)
  1630    S ORMSG(4 )="ORC|SC| "_+IFN_"^O R|"_+IFN_" ^OR||CM||| |||"_DUZ_" ||||"_$$FM THL7^XLFDT ($$NOW^XLF DT)
  1631   "RTN","ORM BLDOR",37, 0)
  1632    D MSG^XQO R("OR EVSE ND VPR",.O RMSG)
  1633   "RTN","ORM BLDOR",38, 0)
  1634    Q
  1635   "RTN","ORM BLDOR",39, 0)
  1636    ;
  1637   "RTN","ORM BLDOR",40, 0)
  1638   VER(IFN) ;  -- Send m sg for ver ified orde rs
  1639   "RTN","ORM BLDOR",41, 0)
  1640    N OR0,ORM SG S OR0=$ G(^OR(100, +IFN,0))
  1641   "RTN","ORM BLDOR",42, 0)
  1642    S ORMSG(1 )=$$MSH^OR MBLD("ORM" ,"OR"),ORM SG(2)=$$PI D^ORMBLD($ P(OR0,U,2) )
  1643   "RTN","ORM BLDOR",43, 0)
  1644    S ORMSG(3 )=$$PV1^OR MBLD($P(OR 0,U,2),$P( OR0,U,12), +$P(OR0,U, 10))
  1645   "RTN","ORM BLDOR",44, 0)
  1646    S ORMSG(4 )="ORC|ZV| "_IFN_"^OR |"_$G(^OR( 100,+IFN,4 ))_U_$$NMS P^ORCD($P( OR0,U,14)) _"|||||||| "_DUZ_"||| |"_$$FMTHL 7^XLFDT($$ NOW^XLFDT)
  1647   "RTN","ORM BLDOR",45, 0)
  1648    D MSG^XQO R("OR EVSE ND VPR",.O RMSG)
  1649   "RTN","ORM BLDOR",46, 0)
  1650    Q
  1651   "RTN","ORW DXA")
  1652   0^4^B83177 974
  1653   "RTN","ORW DXA",1,0)
  1654   ORWDXA ; S LC/KCM/JLI  - Utilite s for Orde r Actions  ;12/14/12   13:38
  1655   "RTN","ORW DXA",2,0)
  1656    ;;3.0;ORD ER ENTRY/R ESULTS REP ORTING;**1 0,85,116,1 32,148,141 ,149,187,2 13,195,215 ,243,280,3 06,390**;D ec 17, 199 7;Build 11 0
  1657   "RTN","ORW DXA",3,0)
  1658    ;
  1659   "RTN","ORW DXA",4,0)
  1660   VALID(VAL, ORID,ACTIO N,ORNP,ORW NAT) ; Is  action val id for ord er?
  1661   "RTN","ORW DXA",5,0)
  1662    N ORACT,O RVP,ORVER, ORIFN,PRTI D S VAL="" ,PRTID=0
  1663   "RTN","ORW DXA",6,0)
  1664    I +ORID=0  S VAL="Th is order h as been de leted." Q
  1665   "RTN","ORW DXA",7,0)
  1666    I '$D(^OR (100,+ORID ,0)) S VAL ="This ord er has bee n deleted! " Q
  1667   "RTN","ORW DXA",8,0)
  1668    I ACTION= "XFR",'$L( $T(XFR^ORC ACT01)) S  ACTION="RW " ; for pr e-POE
  1669   "RTN","ORW DXA",9,0)
  1670    N ORNSS S  ORNSS=1
  1671   "RTN","ORW DXA",10,0)
  1672    I (ACTION ="RN") D V ALSCH^ORWN SS(.ORNSS, ORID)
  1673   "RTN","ORW DXA",11,0)
  1674    I ORNSS=0  S VAL="Th is order c ontains an  invalid a dministrat ion schedu le." Q
  1675   "RTN","ORW DXA",12,0)
  1676    I (ACTION ="RN") D I SVALIV^ORW DPS33(.VAL ,ORID,ACTI ON) I $L(V AL)>0 Q
  1677   "RTN","ORW DXA",13,0)
  1678    S ORIFN=O RID,ORVP=$ P(^OR(100, +ORID,0),U ,2)  ; ORC ACT0 expec ts
  1679   "RTN","ORW DXA",14,0)
  1680    I (ACTION ="RN") D   Q:$L(VAL)
  1681   "RTN","ORW DXA",15,0)
  1682    . N DLG S  DLG=$P(^O R(100,+ORI D,0),U,5)  Q:DLG'[";O RD(101.41, "
  1683   "RTN","ORW DXA",16,0)
  1684    . I $G(^O RD(101.41, +DLG,3))'[ "PROVIDER^ ORCDPSIV"  Q
  1685   "RTN","ORW DXA",17,0)
  1686    . D AUTH^ ORWDPS32(. VAL,ORNP)
  1687   "RTN","ORW DXA",18,0)
  1688    . I VAL S  VAL=$P(VA L,U,2)
  1689   "RTN","ORW DXA",19,0)
  1690    . E  S VA L=""
  1691   "RTN","ORW DXA",20,0)
  1692    S ORVER=$ S(ACTION=" CR":"R",$D (^XUSEC("O RELSE",DUZ )):"N",$D( ^XUSEC("OR EMAS",DUZ) ):"C",1:"^ ")
  1693   "RTN","ORW DXA",21,0)
  1694    I ACTION= "CR" S ACT ION="VR"
  1695   "RTN","ORW DXA",22,0)
  1696    I (ACTION ="ES")!(AC TION="OC") !(ACTION=" RS") S ORA CT=ACTION  ; why not  defined???
  1697   "RTN","ORW DXA",23,0)
  1698    I (ACTION ="VR"),'($ D(^XUSEC(" ORELSE",DU Z))!$D(^XU SEC("OREMA S",DUZ)))  D  Q
  1699   "RTN","ORW DXA",24,0)
  1700    . S VAL=" You are no t authoriz ed to veri fy these o rders."
  1701   "RTN","ORW DXA",25,0)
  1702    I $L(VAL)  Q
  1703   "RTN","ORW DXA",26,0)
  1704    N OIIEN,I SIV,IVOD
  1705   "RTN","ORW DXA",27,0)
  1706    S (ISIV,O IIEN,IVOD) =0
  1707   "RTN","ORW DXA",28,0)
  1708    I (ACTION ="RW")!(AC TION="XX") !(ACTION=" XFR") D  Q :$L(VAL)
  1709   "RTN","ORW DXA",29,0)
  1710    . S ISIV= $P(^OR(100 ,+ORID,0), U,11)
  1711   "RTN","ORW DXA",30,0)
  1712    . I ISIV, ($P(^ORD(1 00.98,ISIV ,0),U,3)=" IV RX") S  IVOD=1
  1713   "RTN","ORW DXA",31,0)
  1714    . D:'IVOD  GTORITM^O RWDXR(.OII EN,+ORID)
  1715   "RTN","ORW DXA",32,0)
  1716    . D:OIIEN  ISACTOI(. VAL,OIIEN)  I $L(VAL) >0 Q
  1717   "RTN","ORW DXA",33,0)
  1718    . N DLG,F RM
  1719   "RTN","ORW DXA",34,0)
  1720    . S DLG=$ P(^OR(100, +ORID,0),U ,5),FRM=0
  1721   "RTN","ORW DXA",35,0)
  1722    . I $P(DL G,";",2)'= "ORD(101.4 1," S DLG= 0
  1723   "RTN","ORW DXA",36,0)
  1724    . I DLG D  FORMID^OR WDXM(.FRM, +DLG)
  1725   "RTN","ORW DXA",37,0)
  1726    . I '(DLG &FRM) D
  1727   "RTN","ORW DXA",38,0)
  1728    . . S VAL ="Copy & C hange are  not implem ented for  this order  that pred ates CPRS. "
  1729   "RTN","ORW DXA",39,0)
  1730    N OREBUIL D
  1731   "RTN","ORW DXA",40,0)
  1732    ;I (ACTIO N="RW")!(A CTION="XFR ")!(ACTION ="RN") D I SVALIV^ORW DPS33(.VAL ,ORID,ACTI ON) I $L(V AL)>0 Q
  1733   "RTN","ORW DXA",41,0)
  1734    I $$VALID ^ORCACT0(O RID,ACTION ,.VAL,$G(O RWNAT)) S  VAL="" ; V AL=error
  1735   "RTN","ORW DXA",42,0)
  1736    I ACTION= "RN",$$UPC TCHK(ORID)  S VAL="Ca nnot renew  this orde r due to a n illegal  character  ""^"" in t he comment s or patie nt instruc tions."
  1737   "RTN","ORW DXA",43,0)
  1738    I ACTION= "RW",$$UPC TCHK(ORID)  S VAL="Ca nnot copy  this order  due to an  illegal c haracter " "^"" in th e comments  or patien t instruct ions."
  1739   "RTN","ORW DXA",44,0)
  1740    Q
  1741   "RTN","ORW DXA",45,0)
  1742    ;
  1743   "RTN","ORW DXA",46,0)
  1744   HOLD(REC,O RID,ORNP)  ; Place or der on hol d
  1745   "RTN","ORW DXA",47,0)
  1746    N ACTDA
  1747   "RTN","ORW DXA",48,0)
  1748    S ACTDA=$ $ACTION^OR CSAVE("HD" ,+ORID,ORN P)
  1749   "RTN","ORW DXA",49,0)
  1750    D GETBYIF N^ORWORR(. REC,+ORID_ ";"_ACTDA)
  1751   "RTN","ORW DXA",50,0)
  1752    Q
  1753   "RTN","ORW DXA",51,0)
  1754   UNHOLD(REC ,ORID,ORNP ) ; Releas e order fr om hold
  1755   "RTN","ORW DXA",52,0)
  1756    N ACTDA
  1757   "RTN","ORW DXA",53,0)
  1758    S ACTDA=$ $ACTION^OR CSAVE("RL" ,+ORID,ORN P)
  1759   "RTN","ORW DXA",54,0)
  1760    D GETBYIF N^ORWORR(. REC,+ORID_ ";"_ACTDA)
  1761   "RTN","ORW DXA",55,0)
  1762    Q
  1763   "RTN","ORW DXA",56,0)
  1764   DC(REC,ORI D,ORNP,ORL ,REASON,DC ORIG,ISNEW ORD) ; Dis continue/C ancel/Dele te order
  1765   "RTN","ORW DXA",57,0)
  1766    N NATURE, CREATE,PRI NT,STATUS, ACTDA,SIGS TS
  1767   "RTN","ORW DXA",58,0)
  1768    N X3,X8,C URRACT
  1769   "RTN","ORW DXA",59,0)
  1770    Q:'+ORID
  1771   "RTN","ORW DXA",60,0)
  1772    I $G(DCOR IG)="" S D CORIG=0
  1773   "RTN","ORW DXA",61,0)
  1774    S CURRACT =0
  1775   "RTN","ORW DXA",62,0)
  1776    S ORL(2)= ORL_";SC(" ,ORL=ORL(2 ),NATURE=" "
  1777   "RTN","ORW DXA",63,0)
  1778    I REASON  S NATURE=$ P(^ORD(100 .02,$P(^OR D(100.03,R EASON,0),U ,7),0),U,2 )
  1779   "RTN","ORW DXA",64,0)
  1780    S:NATURE= "" NATURE= "W"  ; S:O RNP=DUZ NA TURE="E"
  1781   "RTN","ORW DXA",65,0)
  1782    ;change t he way cre ate work t o support  forcing si gnature fo r all DC
  1783   "RTN","ORW DXA",66,0)
  1784    ;reasons
  1785   "RTN","ORW DXA",67,0)
  1786    S CREATE= 1,PRINT=$$ PRINT^ORCA CT2(NATURE )
  1787   "RTN","ORW DXA",68,0)
  1788    ;S CREATE =$$CREATE^ ORX1(NATUR E)
  1789   "RTN","ORW DXA",69,0)
  1790    S X3=$G(^ OR(100,+OR ID,3))
  1791   "RTN","ORW DXA",70,0)
  1792    S CURRACT =$P(X3,U,7 ) S:CURRAC T<1 CURRAC T=+$O(^OR( 100,+ORID, 8,"?"),-1)
  1793   "RTN","ORW DXA",71,0)
  1794    I '$D(^OR (100,+ORID ,8,+$P(ORI D,";",2),0 )) D
  1795   "RTN","ORW DXA",72,0)
  1796    . S X8=$G (^OR(100,+ ORID,8,CUR RACT,0))
  1797   "RTN","ORW DXA",73,0)
  1798    . S SIGST S=$P(X8,U, 4)
  1799   "RTN","ORW DXA",74,0)
  1800    . S $P(OR ID,";",2)= CURRACT
  1801   "RTN","ORW DXA",75,0)
  1802    E  D
  1803   "RTN","ORW DXA",76,0)
  1804    . S X8=^O R(100,+ORI D,8,+$P(OR ID,";",2), 0)
  1805   "RTN","ORW DXA",77,0)
  1806    . S SIGST S=$P(X8,U, 4)
  1807   "RTN","ORW DXA",78,0)
  1808    I '$D(SIG STS) S SIG STS=1
  1809   "RTN","ORW DXA",79,0)
  1810    S STATUS= $P($G(^OR( 100,+ORID, 8,+$P(ORID ,";",2),0) ),U,15)
  1811   "RTN","ORW DXA",80,0)
  1812    I (STATUS =10)!(STAT US=11) D   Q   ; dele te/cancel  unreleased  order
  1813   "RTN","ORW DXA",81,0)
  1814    . N RPLOR D
  1815   "RTN","ORW DXA",82,0)
  1816    . S RPLOR D=$P($G(^O R(100,+ORI D,3)),U,5)     ; repl aced order
  1817   "RTN","ORW DXA",83,0)
  1818    . D GETBY IFN^ORWORR (.REC,ORID )
  1819   "RTN","ORW DXA",84,0)
  1820    . I STATU S=10,($P(X 8,U,4)'=2)  D  ; CANC EL signed,  delayed,  unreleased
  1821   "RTN","ORW DXA",85,0)
  1822    . . ; tak en from CL RDLY^ORCAC T2
  1823   "RTN","ORW DXA",86,0)
  1824    . . I REA SON D SET^ ORCACT2(+O RID,NATURE ,REASON,,D CORIG)
  1825   "RTN","ORW DXA",87,0)
  1826    . . I 'RE ASON D SET ^ORCACT2(+ ORID,"M"," ","Delayed  Order Can celled",DC ORIG)
  1827   "RTN","ORW DXA",88,0)
  1828    . . D STA TUS^ORCSAV E2(+ORID,1 3) S $P(^O R(100,+ORI D,8,1,0),U ,15)=13
  1829   "RTN","ORW DXA",89,0)
  1830    . E  D                              ; CANC EL OR DELE TE unsigne d, unrelea sed
  1831   "RTN","ORW DXA",90,0)
  1832    . . I $P( X8,U,2)="D C" K ^OR(1 00,+ORID,6 )
  1833   "RTN","ORW DXA",91,0)
  1834    . . ; del ete fwd pt r to order  about to  be deleted
  1835   "RTN","ORW DXA",92,0)
  1836    . . I RPL ORD,$P(X8, U,2)="NW"  S $P(^OR(1 00,RPLORD, 3),U,6)=""
  1837   "RTN","ORW DXA",93,0)
  1838    . . ; del ete ptr to  order in  Patient Ev ent file # 100.2
  1839   "RTN","ORW DXA",94,0)
  1840    . . N EVT  S EVT=$P( $G(^OR(100 ,+ORID,0)) ,U,17) I E VT,EVT=+$O (^ORE(100. 2,"AO",+OR ID,0)) S $ P(^ORE(100 .2,EVT,0), U,4)="" K  ^ORE(100.2 ,"AO",+ORI D,EVT)
  1841   "RTN","ORW DXA",95,0)
  1842    . . I $G( ISNEWORD)  D DELETE^O RCSAVE2(OR ID)
  1843   "RTN","ORW DXA",96,0)
  1844    . . I '$G (ISNEWORD)  D CANCEL^ ORCSAVE2(O RID)
  1845   "RTN","ORW DXA",97,0)
  1846    . I RPLOR D,'(SIGSTS =1) S ORID =RPLORD  ;  for Renew s & Change s, show re placed ord er
  1847   "RTN","ORW DXA",98,0)
  1848    . I '$D(^ OR(100,+OR ID)) D
  1849   "RTN","ORW DXA",99,0)
  1850    . . S $P( REC(1),U)= "~0",REC(2 )="tDELETE D: "_$E(RE C(2),2,245 )
  1851   "RTN","ORW DXA",100,0 )
  1852    . E  D
  1853   "RTN","ORW DXA",101,0 )
  1854    . . K REC
  1855   "RTN","ORW DXA",102,0 )
  1856    . . D GET BYIFN^ORWO RR(.REC,+O RID_";"_$P ($G(^OR(10 0,+ORID,3) ),U,7))
  1857   "RTN","ORW DXA",103,0 )
  1858    . S $P(RE C(1),U,14) =2 ; DCTyp e = deleti on
  1859   "RTN","ORW DXA",104,0 )
  1860    S ACTDA=$ $ACTION^OR CSAVE("DC" ,+ORID,ORN P)
  1861   "RTN","ORW DXA",105,0 )
  1862    D SET^ORC ACT2(+ORID ,NATURE,RE ASON,,DCOR IG)
  1863   "RTN","ORW DXA",106,0 )
  1864    D GETBYIF N^ORWORR(. REC,+ORID_ ";"_ACTDA)
  1865   "RTN","ORW DXA",107,0 )
  1866    S $P(REC( 1),U,14)=$ S(CREATE:1 ,1:3)  ;DC Type - 1=N ewOrder, 3 =NewStatus
  1867   "RTN","ORW DXA",108,0 )
  1868    N PKG
  1869   "RTN","ORW DXA",109,0 )
  1870    S PKG=$P( $G(^OR(100 ,+ORID,0)) ,U,14)
  1871   "RTN","ORW DXA",110,0 )
  1872    S PKG=$$N MSP^ORCD(P KG)
  1873   "RTN","ORW DXA",111,0 )
  1874    I REASON= 16&(PKG="P S") D
  1875   "RTN","ORW DXA",112,0 )
  1876    . N XMB
  1877   "RTN","ORW DXA",113,0 )
  1878    . S XMB=" OR DRUG OR DER CANCEL LED"
  1879   "RTN","ORW DXA",114,0 )
  1880    . S XMB(1 )=$P($G(RE C(2)),"tDi scontinue" ,2),XMB(4) =$P($G(^VA (200,DUZ,0 )),U)
  1881   "RTN","ORW DXA",115,0 )
  1882    . S XMB(2 )=+ORID
  1883   "RTN","ORW DXA",116,0 )
  1884    . S XMB(3 )=+$P($G(^ OR(100,+OR ID,0)),U,2 )
  1885   "RTN","ORW DXA",117,0 )
  1886    . S XMB(3 )=$P($G(^D PT(XMB(3), 0)),U)
  1887   "RTN","ORW DXA",118,0 )
  1888    . D ^XMB
  1889   "RTN","ORW DXA",119,0 )
  1890    Q
  1891   "RTN","ORW DXA",120,0 )
  1892   DCREQIEN(V AL) ; Retu rn IEN for  Req Phys  Cancelled  reason
  1893   "RTN","ORW DXA",121,0 )
  1894    S VAL=$O( ^ORD(100.0 3,"S","REQ ",0))
  1895   "RTN","ORW DXA",122,0 )
  1896    Q
  1897   "RTN","ORW DXA",123,0 )
  1898   COMPLETE(R EC,ORID,ES CODE) ; Co mplete ord er (generi c)
  1899   "RTN","ORW DXA",124,0 )
  1900    ;N X S X= +$E($$NOW^ XLFDT,1,12 )
  1901   "RTN","ORW DXA",125,0 )
  1902    ;D DATES^ ORCSAVE2(+ ORID,,X)
  1903   "RTN","ORW DXA",126,0 )
  1904    ;D STATUS ^ORCSAVE2( +ORID,2)
  1905   "RTN","ORW DXA",127,0 )
  1906    ; validat e ESCode
  1907   "RTN","ORW DXA",128,0 )
  1908    D COMP^OR CSAVE2(ORI D)
  1909   "RTN","ORW DXA",129,0 )
  1910    D COMP^OR MBLDOR(ORI D)
  1911   "RTN","ORW DXA",130,0 )
  1912    D GETBYIF N^ORWORR(. REC,ORID)
  1913   "RTN","ORW DXA",131,0 )
  1914    Q
  1915   "RTN","ORW DXA",132,0 )
  1916   VERIFY(REC ,ORID,ESCO DE,ORVER)  ; Verify o rder
  1917   "RTN","ORW DXA",133,0 )
  1918    ; validat e ESCode
  1919   "RTN","ORW DXA",134,0 )
  1920    S ORVER=$ G(ORVER,$S ($D(^XUSEC ("ORELSE", DUZ)):"N", $D(^XUSEC( "OREMAS",D UZ)):"C",1 :U))
  1921   "RTN","ORW DXA",135,0 )
  1922    I ORVER'= U D
  1923   "RTN","ORW DXA",136,0 )
  1924    . N ORIFN ,ORES,ORI
  1925   "RTN","ORW DXA",137,0 )
  1926    . ; VERIF Y any repl aced order s:
  1927   "RTN","ORW DXA",138,0 )
  1928    . S ORIFN =ORID,ORES (ORIFN)=""  D REPLCD^ ORCACT1
  1929   "RTN","ORW DXA",139,0 )
  1930    . S ORI=" " F  S ORI =$O(ORES(O RI)) Q:ORI =""  D EN^ ORCSEND(OR I,"VR","", ""),UNLK1^ ORX2(+ORI) :ORI'=ORID  ;ORID loc ked prior
  1931   "RTN","ORW DXA",140,0 )
  1932    D GETBYIF N^ORWORR(. REC,ORID)
  1933   "RTN","ORW DXA",141,0 )
  1934    Q
  1935   "RTN","ORW DXA",142,0 )
  1936   ALERT(DUMM Y,ORID,ORD UZ) ; aler t user (OR DUZ) when  order (ORI D) resulte d
  1937   "RTN","ORW DXA",143,0 )
  1938    ;if no us er passed,  use order ing provid er:
  1939   "RTN","ORW DXA",144,0 )
  1940    I $G(ORDU Z)<1 S ORD UZ=+$$ORDE RER^ORQOR2 (+ORID)
  1941   "RTN","ORW DXA",145,0 )
  1942    I $L($G(O RDUZ))<1 S  ORDUZ=DUZ
  1943   "RTN","ORW DXA",146,0 )
  1944    S DUMMY=1 ,$P(^OR(10 0,+ORID,3) ,U,10)=ORD UZ
  1945   "RTN","ORW DXA",147,0 )
  1946    Q
  1947   "RTN","ORW DXA",148,0 )
  1948   FLAG(REC,O RIFN,OREAS ON,ORNP) ;  Flag orde r
  1949   "RTN","ORW DXA",149,0 )
  1950    N ORB,ORV P,DA,ORPS
  1951   "RTN","ORW DXA",150,0 )
  1952    D BULLETI N
  1953   "RTN","ORW DXA",151,0 )
  1954    S DA=$P(O RIFN,";",2 ),ORVP=+$P (^OR(100,+ ORIFN,0),U ,2)
  1955   "RTN","ORW DXA",152,0 )
  1956    K ^OR(100 ,+ORIFN,8, DA,3) S ^( 3)="1^"_$G (XMZ)_U_+$ E($$NOW^XL FDT,1,12)_ U_DUZ_U_OR EASON_$S($ G(ORNP):"^ ^^^"_+ORNP ,1:"")
  1957   "RTN","ORW DXA",153,0 )
  1958    D KILL^XM ,MSG^ORCFL AG(ORIFN)
  1959   "RTN","ORW DXA",154,0 )
  1960    S $P(^OR( 100,+ORIFN ,3),U)=$$N OW^XLFDT ;  Last Acti vity
  1961   "RTN","ORW DXA",155,0 )
  1962    I +$G(ORN P)<1 S ORN P=+$P($G(^ OR(100,+OR IFN,8,DA,0 )),U,3)
  1963   "RTN","ORW DXA",156,0 )
  1964    S ORB=+OR VP_U_+ORIF N_U_ORNP_" ^1" D EN^O CXOERR(ORB ) ; notifi cation
  1965   "RTN","ORW DXA",157,0 )
  1966    D GETBYIF N^ORWORR(. REC,ORIFN)
  1967   "RTN","ORW DXA",158,0 )
  1968    Q
  1969   "RTN","ORW DXA",159,0 )
  1970   BULLETIN ;  flagged o rder bulle tin
  1971   "RTN","ORW DXA",160,0 )
  1972    N OR0,OR3 ,ORDTXT,XM B,XMY,XMDU Z,ORENT,BU LL,ORSRV,O RUSR
  1973   "RTN","ORW DXA",161,0 )
  1974    S OR0=$G( ^OR(100,+O RIFN,0)),O R3=$G(^(3) )
  1975   "RTN","ORW DXA",162,0 )
  1976    ;CLA - 3/ 21/96:
  1977   "RTN","ORW DXA",163,0 )
  1978    S ORUSR=+ $P(OR0,U,4 )
  1979   "RTN","ORW DXA",164,0 )
  1980    S ORSRV=$ G(^VA(200, ORUSR,5))  I +ORSRV>0  S ORSRV=$ P(ORSRV,U)
  1981   "RTN","ORW DXA",165,0 )
  1982    S ORENT=" USR.`"_ORU SR_"^SRV.` "_$G(ORSRV )_"^DIV^SY S^PKG"
  1983   "RTN","ORW DXA",166,0 )
  1984    S BULL=$$ GET^XPAR(O RENT,"ORB  FLAGGED OR DERS BULLE TIN",1,"Q" )
  1985   "RTN","ORW DXA",167,0 )
  1986    Q:$G(BULL )'="Y"   ; quit if pa rm val not  'Y'es
  1987   "RTN","ORW DXA",168,0 )
  1988    ;
  1989   "RTN","ORW DXA",169,0 )
  1990    S XMB="OR  FLAGGED O RDER",XMDU Z=DUZ,XMY( +$P(OR0,U, 4))=""
  1991   "RTN","ORW DXA",170,0 )
  1992    S XMB(1)= $P(^DPT(+$ P(OR0,U,2) ,0),U),XMB (2)=$P(^(0 ),U,9),XMB (3)="" ;sb  AGE
  1993   "RTN","ORW DXA",171,0 )
  1994    S XMB(4)= $$FMTE^XLF DT($P(OR0, U,7))
  1995   "RTN","ORW DXA",172,0 )
  1996    D TEXT^OR Q12(.ORDTX T,+ORIFN,8 0)
  1997   "RTN","ORW DXA",173,0 )
  1998    S XMB(5)= $G(ORDTXT( 1)),XMB(6) =$G(ORDTXT (2)),XMB(7 )=$G(ORDTX T(3))
  1999   "RTN","ORW DXA",174,0 )
  2000    S XMB(8)= $$FMTE^XLF DT($P(OR0, U,8)),XMB( 9)=$$FMTE^ XLFDT($P(O R0,U,9)),X MB(10)=ORE ASON
  2001   "RTN","ORW DXA",175,0 )
  2002    S XMB(11) =$P($G(^OR D(100.01,+ $P(OR3,U,3 ),0)),U)
  2003   "RTN","ORW DXA",176,0 )
  2004    D EN^XMB
  2005   "RTN","ORW DXA",177,0 )
  2006    Q
  2007   "RTN","ORW DXA",178,0 )
  2008   UNFLAG(REC ,ORIFN,ORE ASON) ; Un flag order
  2009   "RTN","ORW DXA",179,0 )
  2010    N DA,ORB, ORNP,ORVP, ORPS
  2011   "RTN","ORW DXA",180,0 )
  2012    S DA=$P(O RIFN,";",2 ),ORVP=+$P (^OR(100,+ ORIFN,0),U ,2)
  2013   "RTN","ORW DXA",181,0 )
  2014    S $P(^OR( 100,+ORIFN ,8,DA,3),U )=0,$P(^(3 ),U,6,8)=+ $E($$NOW^X LFDT,1,12) _U_DUZ_U_O REASON D M SG^ORCFLAG (ORIFN)
  2015   "RTN","ORW DXA",182,0 )
  2016    S $P(^OR( 100,+ORIFN ,3),U)=$$N OW^XLFDT   ; Last Act ivity
  2017   "RTN","ORW DXA",183,0 )
  2018    S ORNP=+$ P($G(^OR(1 00,+ORIFN, 8,DA,0)),U ,3)
  2019   "RTN","ORW DXA",184,0 )
  2020    S ORB=+OR VP_U_+ORIF N_U_ORNP_" ^0" D EN^O CXOERR(ORB ) ; notifi cation
  2021   "RTN","ORW DXA",185,0 )
  2022    D GETBYIF N^ORWORR(. REC,ORIFN)
  2023   "RTN","ORW DXA",186,0 )
  2024    Q
  2025   "RTN","ORW DXA",187,0 )
  2026   FLAGTXT(LS T,ORID) ;  flag reaso n
  2027   "RTN","ORW DXA",188,0 )
  2028    N FLAG
  2029   "RTN","ORW DXA",189,0 )
  2030    S FLAG=$G (^OR(100,+ ORID,8,$P( ORID,";",2 ),3))
  2031   "RTN","ORW DXA",190,0 )
  2032    S LST(1)= "FLAGGED:  "_$$FMTE^X LFDT($P(FL AG,U,3))_"  by "_$P($ G(^VA(200, +$P(FLAG,U ,4),0)),U)
  2033   "RTN","ORW DXA",191,0 )
  2034    S LST(2)= $P(FLAG,U, 5) ; reaso n
  2035   "RTN","ORW DXA",192,0 )
  2036    Q
  2037   "RTN","ORW DXA",193,0 )
  2038   WCGET(LST, ORID) ; wa rd comment s
  2039   "RTN","ORW DXA",194,0 )
  2040    N I,ORIFN ,ACT S ORI FN=+ORID,A CT=+$P(ORI D,";",2)
  2041   "RTN","ORW DXA",195,0 )
  2042    S I=0 F   S I=$O(^OR (100,ORIFN ,8,ACT,5,I )) Q:'I  S  LST(I)=$G (^(I,0))
  2043   "RTN","ORW DXA",196,0 )
  2044    Q
  2045   "RTN","ORW DXA",197,0 )
  2046   WCPUT(ERR, ORID,WCLST ) ; Set wa rd comment s
  2047   "RTN","ORW DXA",198,0 )
  2048    N DIERR,E RRLST,ORIF N,ACT S OR IFN=+ORID, ACT=+$P(OR ID,";",2)
  2049   "RTN","ORW DXA",199,0 )
  2050    D WP^DIE( 100.008,AC T_","_ORIF N_",",50," ","WCLST", "ERRLST")
  2051   "RTN","ORW DXA",200,0 )
  2052    S ERR=""  I $D(DIERR ) S ERR="A n error oc curred whi le saving  comments."
  2053   "RTN","ORW DXA",201,0 )
  2054    Q
  2055   "RTN","ORW DXA",202,0 )
  2056   OFCPLX(ORY ,ORID,PRTO RDER) ; is  ORID chil d of PRTOR DER
  2057   "RTN","ORW DXA",203,0 )
  2058    N NUMCHDS ,NOWID,NOW VAL,X3,ORD A,ISNOW
  2059   "RTN","ORW DXA",204,0 )
  2060    Q:'$D(^OR (100,+ORID ,0))
  2061   "RTN","ORW DXA",205,0 )
  2062    S ISNOW=0
  2063   "RTN","ORW DXA",206,0 )
  2064    D ISNOW^O RWDXR(.ISN OW,+ORID)
  2065   "RTN","ORW DXA",207,0 )
  2066    Q:ISNOW
  2067   "RTN","ORW DXA",208,0 )
  2068    N PKG
  2069   "RTN","ORW DXA",209,0 )
  2070    S PKG=$P( $G(^OR(100 ,+ORID,0)) ,U,14)
  2071   "RTN","ORW DXA",210,0 )
  2072    S PKG=$$N MSP^ORCD(P KG)
  2073   "RTN","ORW DXA",211,0 )
  2074    I PKG'="P S" Q
  2075   "RTN","ORW DXA",212,0 )
  2076    I $L($G(^ OR(100,+OR ID,3))),(' $L($P(^(3) ,U,9))) Q
  2077   "RTN","ORW DXA",213,0 )
  2078    S (NUMCHD S,NOWID,NO WVAL,X3,OR DA)=0
  2079   "RTN","ORW DXA",214,0 )
  2080    S PRTORDE R=+$P(^(3) ,U,9)
  2081   "RTN","ORW DXA",215,0 )
  2082    S X3=$G(^ OR(100,PRT ORDER,3)), ORDA=$P(X3 ,U,7)
  2083   "RTN","ORW DXA",216,0 )
  2084    S PRTORDE R=PRTORDER _";"_ORDA
  2085   "RTN","ORW DXA",217,0 )
  2086    S NUMCHDS =$P($G(^OR (100,+PRTO RDER,2,0)) ,U,4)
  2087   "RTN","ORW DXA",218,0 )
  2088    I NUMCHDS >2 S ORY=" COMPLEX-PS I"_U_PRTOR DER
  2089   "RTN","ORW DXA",219,0 )
  2090    S:$D(^OR( 100,+PRTOR DER,4.5,"I D","NOW"))  NOWID=$O( ^("NOW",0) )
  2091   "RTN","ORW DXA",220,0 )
  2092    S:NOWID N OWVAL=$G(^ OR(100,+PR TORDER,4.5 ,NOWID,1))
  2093   "RTN","ORW DXA",221,0 )
  2094    I NOWVAL= 1 Q
  2095   "RTN","ORW DXA",222,0 )
  2096    E  S ORY= "COMPLEX-P SI"_U_PRTO RDER
  2097   "RTN","ORW DXA",223,0 )
  2098    Q
  2099   "RTN","ORW DXA",224,0 )
  2100   ISACTOI(OR Y,OI) ; Is  ord item  active?
  2101   "RTN","ORW DXA",225,0 )
  2102    I $G(^ORD (101.43,+O I,.1)),^(. 1)'>$$NOW^ XLFDT D
  2103   "RTN","ORW DXA",226,0 )
  2104    . S ORY=$ P($G(^ORD( 101.43,OI, 0)),U)_" h as been in activated  and may no t be order ed anymore ."
  2105   "RTN","ORW DXA",227,0 )
  2106    Q
  2107   "RTN","ORW DXA",228,0 )
  2108   UPCTCHK(OR ID) ;
  2109   "RTN","ORW DXA",229,0 )
  2110    ;ORID=ORD ER NUMBER
  2111   "RTN","ORW DXA",230,0 )
  2112    ;RETURNS  1 IF THERE  IS AN UPC ARET IN TH E ORDER'S  COMMENTS
  2113   "RTN","ORW DXA",231,0 )
  2114    N RET,COM MID,WPCNT, PIID S RET =0
  2115   "RTN","ORW DXA",232,0 )
  2116    S COMMID= $O(^OR(100 ,+ORID,4.5 ,"ID","COM MENT",0))
  2117   "RTN","ORW DXA",233,0 )
  2118    I COMMID  S WPCNT=0  F  S WPCNT =$O(^OR(10 0,+ORID,4. 5,COMMID,2 ,WPCNT)) Q :'WPCNT!(R ET)  D
  2119   "RTN","ORW DXA",234,0 )
  2120    .I $G(^OR (100,+ORID ,4.5,COMMI D,2,WPCNT, 0))["^" S  RET=1
  2121   "RTN","ORW DXA",235,0 )
  2122    S PIID=$O (^OR(100,+ ORID,4.5," ID","PI",0 ))
  2123   "RTN","ORW DXA",236,0 )
  2124    I PIID S  WPCNT=0 F   S WPCNT=$ O(^OR(100, +ORID,4.5, PIID,2,WPC NT)) Q:'WP CNT!(RET)   D
  2125   "RTN","ORW DXA",237,0 )
  2126    .I $G(^OR (100,+ORID ,4.5,PIID, 2,WPCNT,0) )["^" S RE T=1
  2127   "RTN","ORW DXA",238,0 )
  2128    Q RET
  2129   "VER")
  2130   8.0^22.0
  2131   **INSTALL  NAME**
  2132   PSB*3.0*79
  2133   "BLD",8918 ,0)
  2134   PSB*3.0*79 ^BAR CODE  MED ADMIN^ 0^3140611^ y
  2135   "BLD",8918 ,1,0)
  2136   ^^1^1^3140 411^
  2137   "BLD",8918 ,1,1,0)
  2138   See patch  descriptio n for deta ils.
  2139   "BLD",8918 ,4,0)
  2140   ^9.64PA^^
  2141   "BLD",8918 ,6)
  2142   1^
  2143   "BLD",8918 ,6.3)
  2144   59
  2145   "BLD",8918 ,"ABPKG")
  2146   n
  2147   "BLD",8918 ,"KRN",0)
  2148   ^9.67PA^77 9.2^20
  2149   "BLD",8918 ,"KRN",.4, 0)
  2150   .4
  2151   "BLD",8918 ,"KRN",.40 1,0)
  2152   .401
  2153   "BLD",8918 ,"KRN",.40 2,0)
  2154   .402
  2155   "BLD",8918 ,"KRN",.40 3,0)
  2156   .403
  2157   "BLD",8918 ,"KRN",.5, 0)
  2158   .5
  2159   "BLD",8918 ,"KRN",.84 ,0)
  2160   .84
  2161   "BLD",8918 ,"KRN",3.6 ,0)
  2162   3.6
  2163   "BLD",8918 ,"KRN",3.8 ,0)
  2164   3.8
  2165   "BLD",8918 ,"KRN",9.2 ,0)
  2166   9.2
  2167   "BLD",8918 ,"KRN",9.8 ,0)
  2168   9.8
  2169   "BLD",8918 ,"KRN",9.8 ,"NM",0)
  2170   ^9.68A^2^2
  2171   "BLD",8918 ,"KRN",9.8 ,"NM",1,0)
  2172   PSBML^^0^B 125339367
  2173   "BLD",8918 ,"KRN",9.8 ,"NM",2,0)
  2174   PSBVPR^^0^ B2149221
  2175   "BLD",8918 ,"KRN",9.8 ,"NM","B", "PSBML",1)
  2176  
  2177   "BLD",8918 ,"KRN",9.8 ,"NM","B", "PSBVPR",2 )
  2178  
  2179   "BLD",8918 ,"KRN",19, 0)
  2180   19
  2181   "BLD",8918 ,"KRN",19. 1,0)
  2182   19.1
  2183   "BLD",8918 ,"KRN",101 ,0)
  2184   101
  2185   "BLD",8918 ,"KRN",101 ,"NM",0)
  2186   ^9.68A^1^1
  2187   "BLD",8918 ,"KRN",101 ,"NM",1,0)
  2188   PSB EVSEND  VPR^^0
  2189   "BLD",8918 ,"KRN",101 ,"NM","B", "PSB EVSEN D VPR",1)
  2190  
  2191   "BLD",8918 ,"KRN",409 .61,0)
  2192   409.61
  2193   "BLD",8918 ,"KRN",771 ,0)
  2194   771
  2195   "BLD",8918 ,"KRN",779 .2,0)
  2196   779.2
  2197   "BLD",8918 ,"KRN",870 ,0)
  2198   870
  2199   "BLD",8918 ,"KRN",898 9.51,0)
  2200   8989.51
  2201   "BLD",8918 ,"KRN",898 9.52,0)
  2202   8989.52
  2203   "BLD",8918 ,"KRN",899 4,0)
  2204   8994
  2205   "BLD",8918 ,"KRN","B" ,.4,.4)
  2206  
  2207   "BLD",8918 ,"KRN","B" ,.401,.401 )
  2208  
  2209   "BLD",8918 ,"KRN","B" ,.402,.402 )
  2210  
  2211   "BLD",8918 ,"KRN","B" ,.403,.403 )
  2212  
  2213   "BLD",8918 ,"KRN","B" ,.5,.5)
  2214  
  2215   "BLD",8918 ,"KRN","B" ,.84,.84)
  2216  
  2217   "BLD",8918 ,"KRN","B" ,3.6,3.6)
  2218  
  2219   "BLD",8918 ,"KRN","B" ,3.8,3.8)
  2220  
  2221   "BLD",8918 ,"KRN","B" ,9.2,9.2)
  2222  
  2223   "BLD",8918 ,"KRN","B" ,9.8,9.8)
  2224  
  2225   "BLD",8918 ,"KRN","B" ,19,19)
  2226  
  2227   "BLD",8918 ,"KRN","B" ,19.1,19.1 )
  2228  
  2229   "BLD",8918 ,"KRN","B" ,101,101)
  2230  
  2231   "BLD",8918 ,"KRN","B" ,409.61,40 9.61)
  2232  
  2233   "BLD",8918 ,"KRN","B" ,771,771)
  2234  
  2235   "BLD",8918 ,"KRN","B" ,779.2,779 .2)
  2236  
  2237   "BLD",8918 ,"KRN","B" ,870,870)
  2238  
  2239   "BLD",8918 ,"KRN","B" ,8989.51,8 989.51)
  2240  
  2241   "BLD",8918 ,"KRN","B" ,8989.52,8 989.52)
  2242  
  2243   "BLD",8918 ,"KRN","B" ,8994,8994 )
  2244  
  2245   "BLD",8918 ,"QUES",0)
  2246   ^9.62^^
  2247   "BLD",8918 ,"REQB",0)
  2248   ^9.611^1^1
  2249   "BLD",8918 ,"REQB",1, 0)
  2250   PSB*3.0*70 ^2
  2251   "BLD",8918 ,"REQB","B ","PSB*3.0 *70",1)
  2252  
  2253   "KRN",101, 6063,-1)
  2254   0^1
  2255   "KRN",101, 6063,0)
  2256   PSB EVSEND  VPR^MEDIC ATION ADMI NISTRATION  EVENTS^^X ^^^^^^^^
  2257   "KRN",101, 6063,1,0)
  2258   ^101.06^2^ 2^3140415^ ^
  2259   "KRN",101, 6063,1,1,0 )
  2260   The purpos e of this  protocol i s to send  notificati on of even ts that mo dify
  2261   "KRN",101, 6063,1,2,0 )
  2262   the BCMA M EDICATION  LOG file ( #53.79).
  2263   "KRN",101, 6063,10,0)
  2264   ^101.01PA^ 2^1
  2265   "KRN",101, 6063,99)
  2266   63349,2443
  2267   "MBREQ")
  2268   1
  2269   "ORD",15,1 01)
  2270   101;15;;;P RO^XPDTA;P ROF1^XPDIA ;PROE1^XPD IA;PROF2^X PDIA;;PROD EL^XPDIA
  2271   "ORD",15,1 01,0)
  2272   PROTOCOL
  2273   "PKG",533, -1)
  2274   1^1
  2275   "PKG",533, 0)
  2276   BAR CODE M ED ADMIN^P SB^BAR COD E MEDICATI ON ADMINIS TRATION
  2277   "PKG",533, 20,0)
  2278   ^9.402P^^
  2279   "PKG",533, 22,0)
  2280   ^9.49I^1^1
  2281   "PKG",533, 22,1,0)
  2282   3.0^304022 4^3040329^ 1000000002 0
  2283   "PKG",533, 22,1,"PAH" ,1,0)
  2284   79^3140611 ^1085
  2285   "PKG",533, 22,1,"PAH" ,1,1,0)
  2286   ^^1^1^3140 611
  2287   "PKG",533, 22,1,"PAH" ,1,1,1,0)
  2288   See patch  descriptio n for deta ils.
  2289   "QUES","XP F1",0)
  2290   Y
  2291   "QUES","XP F1","??")
  2292   ^D REP^XPD H
  2293   "QUES","XP F1","A")
  2294   Shall I wr ite over y our |FLAG|  File
  2295   "QUES","XP F1","B")
  2296   YES
  2297   "QUES","XP F1","M")
  2298   D XPF1^XPD IQ
  2299   "QUES","XP F2",0)
  2300   Y
  2301   "QUES","XP F2","??")
  2302   ^D DTA^XPD H
  2303   "QUES","XP F2","A")
  2304   Want my da ta |FLAG|  yours
  2305   "QUES","XP F2","B")
  2306   YES
  2307   "QUES","XP F2","M")
  2308   D XPF2^XPD IQ
  2309   "QUES","XP I1",0)
  2310   YO
  2311   "QUES","XP I1","??")
  2312   ^D INHIBIT ^XPDH
  2313   "QUES","XP I1","A")
  2314   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  2315   "QUES","XP I1","B")
  2316   NO
  2317   "QUES","XP I1","M")
  2318   D XPI1^XPD IQ
  2319   "QUES","XP M1",0)
  2320   PO^VA(200, :EM
  2321   "QUES","XP M1","??")
  2322   ^D MG^XPDH
  2323   "QUES","XP M1","A")
  2324   Enter the  Coordinato r for Mail  Group '|F LAG|'
  2325   "QUES","XP M1","B")
  2326  
  2327   "QUES","XP M1","M")
  2328   D XPM1^XPD IQ
  2329   "QUES","XP O1",0)
  2330   Y
  2331   "QUES","XP O1","??")
  2332   ^D MENU^XP DH
  2333   "QUES","XP O1","A")
  2334   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  2335   "QUES","XP O1","B")
  2336   NO
  2337   "QUES","XP O1","M")
  2338   D XPO1^XPD IQ
  2339   "QUES","XP Z1",0)
  2340   Y
  2341   "QUES","XP Z1","??")
  2342   ^D OPT^XPD H
  2343   "QUES","XP Z1","A")
  2344   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  2345   "QUES","XP Z1","B")
  2346   NO
  2347   "QUES","XP Z1","M")
  2348   D XPZ1^XPD IQ
  2349   "QUES","XP Z2",0)
  2350   Y
  2351   "QUES","XP Z2","??")
  2352   ^D RTN^XPD H
  2353   "QUES","XP Z2","A")
  2354   Want to MO VE routine s to other  CPUs
  2355   "QUES","XP Z2","B")
  2356   NO
  2357   "QUES","XP Z2","M")
  2358   D XPZ2^XPD IQ
  2359   "RTN")
  2360   2
  2361   "RTN","PSB ML")
  2362   0^1^B12533 9367
  2363   "RTN","PSB ML",1,0)
  2364   PSBML ;BIR MINGHAM/EF C-BCMA MED  LOG FUNCT IONS ;10/2 3/12 12:14 pm
  2365   "RTN","PSB ML",2,0)
  2366    ;;3.0;BAR  CODE MED  ADMIN;**6, 3,4,9,11,1 3,25,45,33 ,52,70,79* *;Mar 2004 ;Build 59
  2367   "RTN","PSB ML",3,0)
  2368    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  2369   "RTN","PSB ML",4,0)
  2370    ; Referen ce/IA
  2371   "RTN","PSB ML",5,0)
  2372    ; ^DPT/10 035
  2373   "RTN","PSB ML",6,0)
  2374    ; DIC(42/ 10039
  2375   "RTN","PSB ML",7,0)
  2376    ; DIC(42/ 2440
  2377   "RTN","PSB ML",8,0)
  2378    ; File 20 0/10060
  2379   "RTN","PSB ML",9,0)
  2380    ; EN^PSJB CMA3/3320
  2381   "RTN","PSB ML",10,0)
  2382    ; $$SITE^ VASITE/101 12
  2383   "RTN","PSB ML",11,0)
  2384    ; ^XUSEC( /10076
  2385   "RTN","PSB ML",12,0)
  2386    ;
  2387   "RTN","PSB ML",13,0)
  2388    ;*70 - st ore clinic  name to a dmin locat ion if exi sts.
  2389   "RTN","PSB ML",14,0)
  2390    ;    - ad d witness  duz, dt/tm  for high  risk/alert  drug, Ord er level
  2391   "RTN","PSB ML",15,0)
  2392    ;      HR  code, and  a witness sed y/n fl ag to MEDL OG file.
  2393   "RTN","PSB ML",16,0)
  2394    ;
  2395   "RTN","PSB ML",17,0)
  2396   RPC(RESULT S,PSBHDR,P SBREC) ;BC MA MedLog  Filing
  2397   "RTN","PSB ML",18,0)
  2398    S PSBEDTF L=0
  2399   "RTN","PSB ML",19,0)
  2400    N PSBORD, PSBTRAN,PS BFDA,PSBME S ;Add PSB MES variab le for PSB *3*52
  2401   "RTN","PSB ML",20,0)
  2402    N PSBCLIN ,PSBWITN,P SBWITCM,PS BWITHR,PSB WITFL,LOC                   ;*70
  2403   "RTN","PSB ML",21,0)
  2404    K PSBIEN, PSBHL7
  2405   "RTN","PSB ML",22,0)
  2406    S PSBIEN= $P(PSBHDR, U,1)
  2407   "RTN","PSB ML",23,0)
  2408    S PSBTRAN =$P(PSBHDR ,U,2),PSBH L7=PSBTRAN
  2409   "RTN","PSB ML",24,0)
  2410    S PSBINST =$P($G(PSB HDR),U,3)
  2411   "RTN","PSB ML",25,0)
  2412    ;*70 witn ess fields
  2413   "RTN","PSB ML",26,0)
  2414    S PSBWITN =+$P(PSBHD R,U,4)                     ;init  witness d uz var
  2415   "RTN","PSB ML",27,0)
  2416    S PSBWITC M=$P(PSBHD R,U,5)                     ;init  witness c omment
  2417   "RTN","PSB ML",28,0)
  2418    S PSBWITH R=+$P(PSBH DR,U,6)                    ;init  witn HR o rder level
  2419   "RTN","PSB ML",29,0)
  2420    S PSBWITF L=$S(PSBWI TN:1,1:0)               ;init wi tnessed?
  2421   "RTN","PSB ML",30,0)
  2422    I PSBWITN ="",PSBWIT HR=3 D  Q
  2423   "RTN","PSB ML",31,0)
  2424    .S RESULT S(0)=1
  2425   "RTN","PSB ML",32,0)
  2426    .S RESULT S(1)="-1^A  Witness i s required , however  Witness in formation  was null."
  2427   "RTN","PSB ML",33,0)
  2428    ;PSB*3*45  We should  be record ing the fi rst entry  in the aud it log.
  2429   "RTN","PSB ML",34,0)
  2430    ;S PSBAUD IT=$S(PSBI EN="+1":0, 1:1)
  2431   "RTN","PSB ML",35,0)
  2432    S PSBAUDI T=1
  2433   "RTN","PSB ML",36,0)
  2434    D NOW^%DT C S PSBNOW =%
  2435   "RTN","PSB ML",37,0)
  2436    I $D(^XUS EC("PSB ST UDENT",DUZ )),PSBINST ="" S RESU LTS(0)=1,R ESULTS(1)= "-1^Instru ctor not p resent" Q
  2437   "RTN","PSB ML",38,0)
  2438    I $D(^XUS EC("PSB ST UDENT",DUZ )),'$D(^XU SEC("PSB I NSTRUCTOR" ,PSBINST))  S RESULTS (0)=1,RESU LTS(1)="-1 ^Instructo r doesn't  have autho rity" Q
  2439   "RTN","PSB ML",39,0)
  2440    S PSBINST (0)=$$GET1 ^DIQ(200,P SBINST_"," ,.01)
  2441   "RTN","PSB ML",40,0)
  2442    I PSBTRAN ="ADD COMM ENT" D COM MENT^PSBML 1 Q
  2443   "RTN","PSB ML",41,0)
  2444    I PSBTRAN ="PRN EFFE CTIVENESS"  D PRN^PSB ML1 Q
  2445   "RTN","PSB ML",42,0)
  2446    ;
  2447   "RTN","PSB ML",43,0)
  2448    ;update m edlog rec
  2449   "RTN","PSB ML",44,0)
  2450   UPD I PSBT RAN="UPDAT E STATUS"  D  Q
  2451   "RTN","PSB ML",45,0)
  2452    .I '$D(^P SB(53.79,P SBIEN)) D   Q
  2453   "RTN","PSB ML",46,0)
  2454    ..S RESUL TS(0)=1
  2455   "RTN","PSB ML",47,0)
  2456    ..S RESUL TS(1)="-1^ Administra tion is at  an UNKNOW N STATUS"
  2457   "RTN","PSB ML",48,0)
  2458    .D UPDATE D^PSBML2
  2459   "RTN","PSB ML",49,0)
  2460    ;
  2461   "RTN","PSB ML",50,0)
  2462    ;edit Med log rec
  2463   "RTN","PSB ML",51,0)
  2464    I PSBTRAN ="EDIT" D  EDIT^PSBML 2 Q
  2465   "RTN","PSB ML",52,0)
  2466    ;
  2467   "RTN","PSB ML",53,0)
  2468    ;SAGG
  2469   "RTN","PSB ML",54,0)
  2470    N PSBWARD  S PSBWARD =$G(^DPT(+ $G(PSBREC( 0)),.1),"U NKNOWN"),^ PSB("SAGG" ,PSBWARD,D T)=$G(^PSB ("SAGG",PS BWARD,DT)) +1
  2471   "RTN","PSB ML",55,0)
  2472    ;*70 save  clinic na me if exis ts before  manipulati ng PSBREC( 1) param
  2473   "RTN","PSB ML",56,0)
  2474    S PSBCLIN =$P(PSBREC (1),U,2) I  PSBCLIN=" " S PSBCLI N=$S($G(PS BCLIEN):$P ($G(^SC(+P SBCLIEN,0) ),"^"),($G (PSBCLORD) ]""):PSBCL ORD,1:"")
  2475   "RTN","PSB ML",57,0)
  2476    S PSBREC( 1)=$P(PSBR EC(1),U)
  2477   "RTN","PSB ML",58,0)
  2478    ;
  2479   "RTN","PSB ML",59,0)
  2480    ;pre-exis ting psbre c(1) manip ulation lo gic to *70
  2481   "RTN","PSB ML",60,0)
  2482    I PSBREC( 1)?1U1";"1 .6N S PSBR EC(1)=$P(P SBREC(1)," ;",1)_$E(P SBREC(1))
  2483   "RTN","PSB ML",61,0)
  2484    D PSJ1^PS BVT(PSBREC (0),$P(PSB REC(1),";" ,2)_$P(PSB REC(1),";" ,1))
  2485   "RTN","PSB ML",62,0)
  2486    S PSBTAB= $P(PSBREC( 9),U,1),PS BUID=$P(PS BREC(9),U, 2)
  2487   "RTN","PSB ML",63,0)
  2488   MEDP D:PSB TRAN="MEDP ASS"
  2489   "RTN","PSB ML",64,0)
  2490    .I (PSBDO SEF["PATCH "),(PSBREC (3)="G") D   Q:+$G(RE SULTS(1))< 0
  2491   "RTN","PSB ML",65,0)
  2492    ..S PSBXD T="" F  S  PSBXDT=$O( ^PSB(53.79 ,"AORDX",P SBDFN,PSBO NX,PSBXDT) ) Q:PSBXDT =""  D  Q: +$G(RESULT S(1))<0
  2493   "RTN","PSB ML",66,0)
  2494    ...S PSBY Z="" F  S  PSBYZ=$O(^ PSB(53.79, "AORDX",PS BDFN,PSBON X,PSBXDT,P SBYZ)) Q:' PSBYZ  I ( "G"[$$GET1 ^DIQ(53.79 ,PSBYZ,.09 ,"I")) D   Q
  2495   "RTN","PSB ML",67,0)
  2496    ....S:($$ GET1^DIQ(5 3.79,PSBYZ ,.09,"I")= "G") RESUL TS(0)=1,RE SULTS(1)=" -1^Previou s Patch ha s not been  removed.  Administra tion cance led."
  2497   "RTN","PSB ML",68,0)
  2498    ....S:($$ GET1^DIQ(5 3.79,PSBYZ ,.09,"I")= "")&(($$GE T1^DIQ(53. 79,PSBYZ,. 07,"I")'=D UZ)&('$D(^ XUSEC("PSB  MANAGER", DUZ)))) RE SULTS(0)=1 ,RESULTS(1 )="-1^Patc h status " "*UNKNOWN* "". Admini stration c anceled."
  2499   "RTN","PSB ML",69,0)
  2500    .I PSBREC (7)="BCMA/ CPRS Inter face Entry ." S PSBNO W=PSBREC(5 )  ;MOB
  2501   "RTN","PSB ML",70,0)
  2502    .F X=0:1: 9 S PSBREC (X)=$G(PSB REC(X))
  2503   "RTN","PSB ML",71,0)
  2504    .I PSBREC (1)?1U1";" .N S PSBRE C(1)=$P(PS BREC(1),"; ",2)_$P(PS BREC(1),"; ",1)
  2505   "RTN","PSB ML",72,0)
  2506    .I PSBREC (1)["V",+P SBREC(5)>0 ,+$P(PSBRE C(5),".",2 )=0,PSBIVT '["P" D NO W^%DTC S P SBREC(5)=$ P(PSBREC(5 ),".",1)_" ."_$P(%,". ",2)
  2507   "RTN","PSB ML",73,0)
  2508    .I $P(PSB REC(9),U,1 )="IVTAB", $P(PSBREC( 9),U,2)=""  S PSBUID= $$GETWSID^ PSBVDLU2(P SBREC(0),P SBREC(1))
  2509   "RTN","PSB ML",74,0)
  2510    .I $P(PSB REC(9),U,1 )="PBTAB", $P(PSBREC( 9),U,2)="" ,PSBREC(1) '["U",PSBR EC(3)'="M" ,PSBREC(3) '="R",PSBR EC(3)'="H"  S PSBUID= $$GETWSID^ PSBVDLU2(P SBREC(0),P SBREC(1))
  2511   "RTN","PSB ML",75,0)
  2512    .;OnCal
  2513   "RTN","PSB ML",76,0)
  2514    .D:PSBREC (2)="OC"
  2515   "RTN","PSB ML",77,0)
  2516    ..S X=$O( ^PSB(53.79 ,"AORD",PS BREC(0),PS BREC(1),"" )) Q:X=""
  2517   "RTN","PSB ML",78,0)
  2518    ..S Y=$O( ^PSB(53.79 ,"AORD",PS BREC(0),PS BREC(1),X, 0))
  2519   "RTN","PSB ML",79,0)
  2520    ..I $P(^P SB(53.79,Y ,0),U,9)=" G"&('$$GET ^XPAR("DIV ","PSB ADM IN MULTIPL E ONCALL") ) D ERR(1, "On-Call a lready giv en")
  2521   "RTN","PSB ML",80,0)
  2522    .;1x
  2523   "RTN","PSB ML",81,0)
  2524    .D:PSBREC (2)="O"
  2525   "RTN","PSB ML",82,0)
  2526    ..S X=$O( ^PSB(53.79 ,"AORD",PS BREC(0),PS BREC(1),"" )) Q:X=""
  2527   "RTN","PSB ML",83,0)
  2528    ..S Y=$O( ^PSB(53.79 ,"AORD",PS BREC(0),PS BREC(1),X, 0))
  2529   "RTN","PSB ML",84,0)
  2530    ..I $P(^P SB(53.79,Y ,0),U,9)=" G" D ERR(1 ,"One Time  already G iven")
  2531   "RTN","PSB ML",85,0)
  2532    .;PRN
  2533   "RTN","PSB ML",86,0)
  2534    .I PSBREC (2)="P",PS BREC(3)'=" M",$P(PSBR EC(9),U,1) '="IVTAB"  D
  2535   "RTN","PSB ML",87,0)
  2536    ..I PSBRE C(6)="" D  ERR(1,"PRN  Medicatio ns MUST Ha ve a PRN R eason")
  2537   "RTN","PSB ML",88,0)
  2538    ..I PSBRE C(5)]"" D  ERR(1,"PRN  Orders do n't have s cheduled t imes")
  2539   "RTN","PSB ML",89,0)
  2540    ..I PSBRE C(3)'="G"  D ERR(1,"P RN Orders  cannot be  marked NOT  Given")
  2541   "RTN","PSB ML",90,0)
  2542    .;Cnt
  2543   "RTN","PSB ML",91,0)
  2544    .I PSBREC (2)="C",PS BTAB'="IVT AB" D
  2545   "RTN","PSB ML",92,0)
  2546    ..D:PSBRE C(5)="" ER R(1,"Conti nuous Orde r needs ad min time")
  2547   "RTN","PSB ML",93,0)
  2548    ..D:PSBRE C(6)]"" ER R(1,"No PR N Reason a llowed on  Continuous  Orders")
  2549   "RTN","PSB ML",94,0)
  2550    .I PSBREC (2)="C",$D (^PSB(53.7 9,"AORD",P SBREC(0),P SBREC(1),+ PSBREC(5)) ),PSBIEN=" +1" D  K P SBADMBY,PS BADMAT Q:P SBSIEN=""   Q:$P(^PSB (53.79,PSB SIEN,0),U, 9)'="N"
  2551   "RTN","PSB ML",95,0)
  2552    ..S PSBSI EN=$O(^PSB (53.79,"AO RD",PSBREC (0),PSBREC (1),PSBREC (5),""))
  2553   "RTN","PSB ML",96,0)
  2554    ..I PSBSI EN]"" I '( ($P(^PSB(5 3.79,PSBSI EN,0),U,7) =DUZ)!($D( ^XUSEC("PS B MANAGER" ,DUZ)))) S  PSBSIEN=" "
  2555   "RTN","PSB ML",97,0)
  2556    ..I PSBSI EN']"" S R ESULTS(0)= 2,RESULTS( 1)="-2^Err or Filing  Transactio n MEDPASS" ,RESULTS(2 )="The PSB  MANAGER k ey is requ ired to mo dify this  scheduled  admin" Q
  2557   "RTN","PSB ML",98,0)
  2558    ..D:$P(^P SB(53.79,P SBSIEN,0), U,9)'="N"
  2559   "RTN","PSB ML",99,0)
  2560    ...K PSBI NCX I $P(^ PSB(53.79, PSBSIEN,0) ,U,9)="" S  PSBINCX=P SBSIEN L + ^PSB(53.79 ,PSBINCX): 1 Q:'$T  L  -^PSB(53. 79,PSBINCX )
  2561   "RTN","PSB ML",100,0)
  2562    ...S Y=$P (^PSB(53.7 9,PSBSIEN, 0),U,6) D  DD^%DT S P SBADMAT=Y
  2563   "RTN","PSB ML",101,0)
  2564    ...S PSBA DMBY=$$GET 1^DIQ(200, $P(^PSB(53 .79,PSBSIE N,0),U,7), .01,)
  2565   "RTN","PSB ML",102,0)
  2566    ...S RESU LTS(0)=3,R ESULTS(1)= "-2^Error  Filing Tra nsaction M EDPASS"
  2567   "RTN","PSB ML",103,0)
  2568    ...S RESU LTS(2)="Co ntinuous A dministrat ion Date/T ime alread y on file. "
  2569   "RTN","PSB ML",104,0)
  2570    ...S RESU LTS(3)="Ad ministered  by "_PSBA DMBY_" at  "_PSBADMAT _"."
  2571   "RTN","PSB ML",105,0)
  2572    ...I $D(X WB) S RESU LTS(0)=RES ULTS(0)+2, RESULTS(4) ="                                             ",RESUL TS(5)="             V DL will no w be updat ed."
  2573   "RTN","PSB ML",106,0)
  2574    .;Non Giv en
  2575   "RTN","PSB ML",107,0)
  2576    .I PSBREC (3)'="G",P SBREC(3)'= "M",PSBUID '["V",PSBU ID'["W" D
  2577   "RTN","PSB ML",108,0)
  2578    ..I PSBRE C(7)="",PS BTAB'="IVT AB" D ERR( 1,"Comment  needed if  Not Marke d Given")
  2579   "RTN","PSB ML",109,0)
  2580    ..I PSBRE C(7)="",PS BTAB="IVTA B" D ERR(1 ,"Comment  needed if  Not Marked  Completed ")
  2581   "RTN","PSB ML",110,0)
  2582    .S:PSBREC (3)="H" PS BREC(7)="H eld: "_PSB REC(7)     ;.3
  2583   "RTN","PSB ML",111,0)
  2584    .S:PSBREC (3)="R" PS BREC(7)="R efused: "_ PSBREC(7)  ;.3
  2585   "RTN","PSB ML",112,0)
  2586    .S:PSBREC (3)="S" PS BREC(7)="S topped: "_ PSBREC(7)  ;.3
  2587   "RTN","PSB ML",113,0)
  2588    .;Valid?
  2589   "RTN","PSB ML",114,0)
  2590    .I $G(PSB SIEN)'=""  I $D(^PSB( 53.79,PSBS IEN,0)) I  $P(^PSB(53 .79,PSBSIE N,0),U,9)= "N" S PSBI EN=+PSBSIE N_",",$P(P SBHDR,U)=P SBIEN,PSBT RAN="UPDAT E STATUS", PSBAUDIT=1                     ; do UPDATE
  2591   "RTN","PSB ML",115,0)
  2592    .D:PSBIEN ="+1"                             ;New fiel ds only?
  2593   "RTN","PSB ML",116,0)
  2594    ..D VAL(5 3.79,PSBIE N,.01,"`"_ PSBREC(0))             ;Patn
  2595   "RTN","PSB ML",117,0)
  2596    ..S LOC=$ G(^DPT(PSB REC(0),.1) )_" "_$G(^ (.101))     ;Ward Roo m/Bed LOC
  2597   "RTN","PSB ML",118,0)
  2598    ..S:PSBCL IN]"" LOC= PSBCLIN          ;If  clinic ord er use cli n name *70
  2599   "RTN","PSB ML",119,0)
  2600    ..D VAL(5 3.79,PSBIE N,.02,LOC)                        ;Patn Loc ation LOC
  2601   "RTN","PSB ML",120,0)
  2602    ..D:$G(^D PT(PSBREC( 0),.1))'=" "
  2603   "RTN","PSB ML",121,0)
  2604    ...S Y=$O (^DIC(42," B",$G(^DPT (PSBREC(0) ,.1)),"")) ,Y=$$GET1^ DIQ(42,Y,. 015,"I"),P SBDIV=$$SI TE^VASITE( DT,Y)
  2605   "RTN","PSB ML",122,0)
  2606    ...D VAL( 53.79,PSBI EN,.03,"`" _$P(PSBDIV ,U,1))      ;Div
  2607   "RTN","PSB ML",123,0)
  2608    ..D VAL(5 3.79,PSBIE N,.04,PSBN OW)                    ;Entered  dt/tm
  2609   "RTN","PSB ML",124,0)
  2610    ..D VAL(5 3.79,PSBIE N,.05,"`"_ DUZ)                   ;Entered  by duz
  2611   "RTN","PSB ML",125,0)
  2612    ..D VAL(5 3.79,PSBIE N,.06,PSBN OW)                    ;Admin dt /tm
  2613   "RTN","PSB ML",126,0)
  2614    ..D VAL(5 3.79,PSBIE N,.07,"`"_ DUZ)                   ;Admin By  duz
  2615   "RTN","PSB ML",127,0)
  2616    ..D VAL(5 3.79,PSBIE N,.08,"`"_ PSBREC(4))             ;Orderabl e Item
  2617   "RTN","PSB ML",128,0)
  2618    ..D VAL(5 3.79,PSBIE N,.11,PSBR EC(1))                 ;Ord file  55 IEN
  2619   "RTN","PSB ML",129,0)
  2620    ..D VAL(5 3.79,PSBIE N,.12,PSBR EC(2))                 ;Ord Schd  Type
  2621   "RTN","PSB ML",130,0)
  2622    ..D VAL(5 3.79,PSBIE N,.13,PSBR EC(5))                 ;Schd Adm  dt/tm
  2623   "RTN","PSB ML",131,0)
  2624    ..D:PSBTA B'="UDTAB"  VAL(53.79 ,PSBIEN,.2 6,PSBUID)   ;IV Bag I D
  2625   "RTN","PSB ML",132,0)
  2626    ..D:PSBTA B="IVTAB"  VAL(53.79, PSBIEN,.13 ,"")        ;Schd Adm dt/tm null
  2627   "RTN","PSB ML",133,0)
  2628    ..D:PSBRE C(1)?.N1"U " VAL(53.7 9,PSBIEN,. 15,PSBDOSE )  ;UD Dos age
  2629   "RTN","PSB ML",134,0)
  2630    ..D:PSBRE C(1)?.N1"V " VAL(53.7 9,PSBIEN,. 35,PSBIFR)    ;IV Inf use Rate
  2631   "RTN","PSB ML",135,0)
  2632    ..I PSBWI THR>1,(PSB REC(3)="G" )!(PSBREC( 3)="I") D           ; Witness lo gic and Gi ve?  *70
  2633   "RTN","PSB ML",136,0)
  2634    ...D:PSBW ITN VAL(53 .79,PSBIEN ,.28,PSBNO W)         ;Witness d t/time
  2635   "RTN","PSB ML",137,0)
  2636    ...D:PSBW ITN VAL(53 .79,PSBIEN ,.29,"`"_P SBWITN)    ;Witness d uz
  2637   "RTN","PSB ML",138,0)
  2638    ...D:PSBW ITCM]"" VA L(53.79,PS BIEN,.31,P SBWITCM)   ;Witness c omment
  2639   "RTN","PSB ML",139,0)
  2640    ...D VAL( 53.79,PSBI EN,.32,PSB WITHR)                ;Witness H R ord code
  2641   "RTN","PSB ML",140,0)
  2642    ...D VAL( 53.79,PSBI EN,.33,PSB WITFL)                ;Witnessed ? flag
  2643   "RTN","PSB ML",141,0)
  2644    .;
  2645   "RTN","PSB ML",142,0)
  2646    .;Overwri te fields  below, rec  already e xsts
  2647   "RTN","PSB ML",143,0)
  2648    .I PSBREC (3)="G"!(P SBREC(3))= "C" D                  ;Gvn/Comp leted?
  2649   "RTN","PSB ML",144,0)
  2650    ..D VAL(5 3.79,PSBIE N,.06,PSBN OW)                      ;Admin  dt/tm
  2651   "RTN","PSB ML",145,0)
  2652    ..D VAL(5 3.79,PSBIE N,.07,"`"_ DUZ)                     ;Admin  By duz
  2653   "RTN","PSB ML",146,0)
  2654    .D:PSBREC (8)]"" VAL (53.79,PSB IEN,.16,PS BREC(8))    ;InjctSte
  2655   "RTN","PSB ML",147,0)
  2656    .D:'$G(PS BMMEN) VAL (53.79,PSB IEN,.09,PS BREC(3))    ;AStats
  2657   "RTN","PSB ML",148,0)
  2658    .I PSBREC (6)]"" D                                     ;PRN reas on?
  2659   "RTN","PSB ML",149,0)
  2660    ..D VAL(5 3.79,PSBIE N,.21,$P(P SBREC(6),U ))            ;reason  dt/tm
  2661   "RTN","PSB ML",150,0)
  2662    ..D VAL(5 3.79,PSBIE N,.27,$P(P SBREC(6),U ,2))          ;PRN re ason
  2663   "RTN","PSB ML",151,0)
  2664    .D:PSBREC (7)]""
  2665   "RTN","PSB ML",152,0)
  2666    ..D VAL(5 3.793,"+2, "_PSBIEN,. 01,PSBREC( 7))         ;Comment
  2667   "RTN","PSB ML",153,0)
  2668    ..D VAL(5 3.793,"+2, "_PSBIEN,. 02,"`"_DUZ )           ;comnt pe rson duz
  2669   "RTN","PSB ML",154,0)
  2670    ..D VAL(5 3.793,"+2, "_PSBIEN,. 03,PSBNOW)             ;comnt dt /time
  2671   "RTN","PSB ML",155,0)
  2672    .;DD/SOL/ ADD
  2673   "RTN","PSB ML",156,0)
  2674    .I PSBREC (3)="G"!(P SBREC(3)=" I")!(PSBRE C(3)="H")! (PSBREC(3) ="R")!(PSB REC(3)="M" ) D     ;g iven/actio n stat cod es?
  2675   "RTN","PSB ML",157,0)
  2676    ..I PSBTR AN="UPDATE  STATUS" K  ^PSB(53.7 9,+PSBIEN, .5),^PSB(5 3.79,+PSBI EN,.6),^PS B(53.79,+P SBIEN,.7)
  2677   "RTN","PSB ML",158,0)
  2678    ..F PSBCN T=10:1 Q:' $D(PSBREC( PSBCNT))   D
  2679   "RTN","PSB ML",159,0)
  2680    ...S Y=$P (PSBREC(PS BCNT),U)
  2681   "RTN","PSB ML",160,0)
  2682    ...S PSBD D=$S(Y="DD ":53.795,Y ="ADD":53. 796,Y="SOL ":53.797,1 :0)
  2683   "RTN","PSB ML",161,0)
  2684    ...Q:'PSB DD
  2685   "RTN","PSB ML",162,0)
  2686    ...S PSBI ENS="+"_PS BCNT_","_P SBIEN
  2687   "RTN","PSB ML",163,0)
  2688    ...D VAL( PSBDD,PSBI ENS,.01,"` "_$P(PSBRE C(PSBCNT), U,2))
  2689   "RTN","PSB ML",164,0)
  2690    ...D VAL( PSBDD,PSBI ENS,.02,$P (PSBREC(PS BCNT),U,3) )
  2691   "RTN","PSB ML",165,0)
  2692    ...D VAL( PSBDD,PSBI ENS,.03,$P (PSBREC(PS BCNT),U,4) )
  2693   "RTN","PSB ML",166,0)
  2694    ...D:(PSB TAB="UDTAB ")!(PSBTAB ="PBTAB")  VAL(PSBDD, PSBIENS,.0 4,$E($P(PS BREC(PSBCN T),U,5),1, 40))
  2695   "RTN","PSB ML",167,0)
  2696    ...D VAL( PSBDD,PSBI ENS,.05,$P (PSBREC(PS BCNT),U,7) )        ; HR ind *70
  2697   "RTN","PSB ML",168,0)
  2698    .;Modify  Filing Tra nsaction M edpass err or message  too incld e details  - PSB*3*52
  2699   "RTN","PSB ML",169,0)
  2700    .I $O(RES ULTS(""))  D  Q
  2701   "RTN","PSB ML",170,0)
  2702    ..N PSBER R
  2703   "RTN","PSB ML",171,0)
  2704    ..I $D(PS BMES) D
  2705   "RTN","PSB ML",172,0)
  2706    ...S RESU LTS(1)="-2 ^***Your d ocumentati on is NOT  being reco rded in th e patient  record.*** ",RESULTS( 2)=""
  2707   "RTN","PSB ML",173,0)
  2708    ...S RESU LTS(3)="Pl ease write  down the  informatio n (below)  AND contac t your BCM A Coordina tor or IT  Support fo r assistan ce:",RESUL TS(4)=""
  2709   "RTN","PSB ML",174,0)
  2710    ...S RESU LTS(5)="Er ror(s) Fil ing Transa ction MEDP ASS"
  2711   "RTN","PSB ML",175,0)
  2712    ..S PSBER R=0 F  S P SBERR=$O(P SBMES(PSBE RR)) Q:PSB ERR=""  D
  2713   "RTN","PSB ML",176,0)
  2714    ...S RESU LTS($O(RES ULTS(""),- 1)+1)=PSBM ES(PSBERR) ,RESULTS(0 )=$O(RESUL TS(""),-1)
  2715   "RTN","PSB ML",177,0)
  2716    .;
  2717   "RTN","PSB ML",178,0)
  2718    .D FILEIT
  2719   "RTN","PSB ML",179,0)
  2720    .;
  2721   "RTN","PSB ML",180,0)
  2722    .;PSB*3*3 3
  2723   "RTN","PSB ML",181,0)
  2724    .D:((PSBR EC(2)="O") !($$ONE^PS JBCMA(PSBR EC(0),PSBR EC(1))="O" ))&(PSBREC (3)="G") E XPIRE^PSBM L1  ;1x ex p?
  2725   "RTN","PSB ML",182,0)
  2726    .D:(PSBRE C(2)="O")& (PSBREC(3) ="G") EXPI RE^PSBML1   ;1x exp?
  2727   "RTN","PSB ML",183,0)
  2728    .I $P(RES ULTS(0),U, 1)=1,PSBTA B'="UDTAB" ,PSBUID]"" ,PSBUID'[" WS" S PSBO N=+PSBREC( 1) D EN^PS JBCMA3(PSB REC(0),PSB ON,PSBUID, PSBREC(3), PSBNOW)
  2729   "RTN","PSB ML",184,0)
  2730    Q
  2731   "RTN","PSB ML",185,0)
  2732   BCBU ;HL7, NatContng
  2733   "RTN","PSB ML",186,0)
  2734    Q:+$G(RES ULTS(0))'> 0
  2735   "RTN","PSB ML",187,0)
  2736    N PSBIEN1  S PSBIEN1 =$S($P(PSB IEN,",",2) '="":+$P(P SBIEN,",", 2),$G(PSBI EN)="+1":P SBIEN(1),1 :+$G(PSBIE N))
  2737   "RTN","PSB ML",188,0)
  2738    I $G(PSBI EN1)="" S  RESULTS(0) =1,RESULTS (1)="-1^Co ntingency  NOT proces sed" Q
  2739   "RTN","PSB ML",189,0)
  2740    I $G(PSBI EN)="+1" S  PSBHL7="M EDPASS"
  2741   "RTN","PSB ML",190,0)
  2742    E  S:$G(P SBHL7)=""  PSBHL7="UP DATE STATU S"
  2743   "RTN","PSB ML",191,0)
  2744    D:('$D(Y( 0))!($G(Y( 0))="SAVE" )!($G(Y(0) )="YES"))  EN^PSBSVHL 7(+PSBIEN1 ,PSBHL7),M EDL^ALPBCB U(+PSBIEN1 ) K PSBHL7
  2745   "RTN","PSB ML",192,0)
  2746    ;<<HDR-VD EF(frm *3)
  2747   "RTN","PSB ML",193,0)
  2748    Q
  2749   "RTN","PSB ML",194,0)
  2750   VAL(PSBDD, PSBIEN,PSB FLD,PSBVAL ) ;
  2751   "RTN","PSB ML",195,0)
  2752    K ^TMP("D IERR",$J), PSBRET
  2753   "RTN","PSB ML",196,0)
  2754    D VAL^DIE (PSBDD,PSB IEN,PSBFLD ,"F",PSBVA L,.PSBRET, "PSBFDA")
  2755   "RTN","PSB ML",197,0)
  2756    I PSBRET= "^" F X=0: 0 S X=$O(^ TMP("DIERR ",$J,X)) Q :'X  D ERR (2,^TMP("D IERR",$J,X )_": "_$G( ^(X,"TEXT" ,1),"**"))
  2757   "RTN","PSB ML",198,0)
  2758    K ^TMP("D IERR",$J), PSBRET
  2759   "RTN","PSB ML",199,0)
  2760    Q
  2761   "RTN","PSB ML",200,0)
  2762   FILEIT ;Up dt
  2763   "RTN","PSB ML",201,0)
  2764    N PSBMSG, PSBAUD
  2765   "RTN","PSB ML",202,0)
  2766    S (PSB1,P SB2)=""
  2767   "RTN","PSB ML",203,0)
  2768    D APATCH^ PSBML3
  2769   "RTN","PSB ML",204,0)
  2770    D CLEAN^D ILF
  2771   "RTN","PSB ML",205,0)
  2772    D RESETAD M^PSBUTL
  2773   "RTN","PSB ML",206,0)
  2774    D UPDATE^ DIE("","PS BFDA","PSB IEN","PSBM SG")
  2775   "RTN","PSB ML",207,0)
  2776    I '$G(PSB MMEN) S X= +PSBIEN I  $F("HR",$P (^PSB(53.7 9,X,0),U,9 ))>1 F Y=. 5,.6,.7 S  Z=0 F  S Z =$O(^PSB(5 3.79,+X,Y, Z)) Q:+Z=0   S $P(^PS B(53.79,+X ,Y,Z,0),U, 3)=0
  2777   "RTN","PSB ML",208,0)
  2778    I $D(PSBM SG("DIERR" )) S RESUL TS(0)=1,RE SULTS(1)=" -1^"_PSBMS G("DIERR", 1)_": "_PS BMSG("DIER R",1,"TEXT ",1)  Q
  2779   "RTN","PSB ML",209,0)
  2780    I $G(PSB1 )]"" X PSB 1 I $G(PSB 2)]"" X PS B2
  2781   "RTN","PSB ML",210,0)
  2782    I $D(PSBH DR) D:"NHM R"[$P(^PSB (53.79,$S( $P(PSBHDR, "^",1)="+1 ":PSBIEN(1 ),1:+PSBIE N),0),U,9)
  2783   "RTN","PSB ML",211,0)
  2784    .N PSBIND X S PSBIND X=$S($P(PS BHDR,"^",1 )="+1":PSB IEN(1),1:+ PSBIEN)
  2785   "RTN","PSB ML",212,0)
  2786    .K ^PSB(5 3.79,"APAT CH",$P(^PS B(53.79,PS BINDX,0),U ),$P(^PSB( 53.79,PSBI NDX,0),U,6 ),PSBINDX)
  2787   "RTN","PSB ML",213,0)
  2788    S RESULTS (0)=1,RESU LTS(1)="1^ Data Succe ssfully Fi led^"_$S($ G(PSBIEN(1 ))'="":$G( PSBIEN(1)) ,1:+$G(PSB IEN))
  2789   "RTN","PSB ML",214,0)
  2790    D BCBU  ; NatContng
  2791   "RTN","PSB ML",215,0)
  2792    D  ;
  2793   "RTN","PSB ML",216,0)
  2794    . N X,DIC
  2795   "RTN","PSB ML",217,0)
  2796    . S X="PS B EVSEND V PR",DIC=10 1 D EN^XQO R ;should  handle all  BCMA Med  Log events  for VPR
  2797   "RTN","PSB ML",218,0)
  2798    I $G(PSBI NST,0) S P SBAUD=$S($ P(PSBHDR," ^",1)="+1" :PSBIEN(1) ,1:$P(PSBH DR,"^",1))  D AUDIT^P SBMLU(PSBA UD,"Instru ctor "_PSB INST(0)_"  present.", PSBTRAN)
  2799   "RTN","PSB ML",219,0)
  2800    Q
  2801   "RTN","PSB ML",220,0)
  2802   ERR(X,Y) ;
  2803   "RTN","PSB ML",221,0)
  2804    S X=$P("B usiness Lo gic Error^ Data Valid ation Erro r",U,X)
  2805   "RTN","PSB ML",222,0)
  2806    S RESULTS ($O(RESULT S(""),-1)+ 1)=X_": "_ Y
  2807   "RTN","PSB ML",223,0)
  2808    S PSBMES( $O(PSBMES( ""),-1)+1) =X_": "_Y
  2809   "RTN","PSB ML",224,0)
  2810    Q
  2811   "RTN","PSB ML",225,0)
  2812   COMMENT(DA ,PSBCMT) ;
  2813   "RTN","PSB ML",226,0)
  2814    N PSBFDA, PSBIEN,PSB NOW
  2815   "RTN","PSB ML",227,0)
  2816    S PSBIEN= "+1,"_DA_" ,"
  2817   "RTN","PSB ML",228,0)
  2818    D NOW^%DT C S PSBNOW =%
  2819   "RTN","PSB ML",229,0)
  2820    D VAL(53. 793,PSBIEN ,.01,PSBCM T)
  2821   "RTN","PSB ML",230,0)
  2822    S PSBFDA( 53.793,PSB IEN,.02)=D UZ
  2823   "RTN","PSB ML",231,0)
  2824    S PSBFDA( 53.793,PSB IEN,.03)=P SBNOW
  2825   "RTN","PSB ML",232,0)
  2826    D FILEIT
  2827   "RTN","PSB ML",233,0)
  2828    Q
  2829   "RTN","PSB VPR")
  2830   0^2^B21492 21
  2831   "RTN","PSB VPR",1,0)
  2832   PSBVPR ;SL C/JLC- BCM A-VPR UTIL ITIES ;11/ 15/12 2:40 pm
  2833   "RTN","PSB VPR",2,0)
  2834    ;;3.0;BAR  CODE MED  ADMIN;**79 **;Mar 200 4;Build 59
  2835   "RTN","PSB VPR",3,0)
  2836    ;Per VHA  Directive  2004-038 ( or future  revisions  regarding  same), thi s routine  should not  be modifi ed.
  2837   "RTN","PSB VPR",4,0)
  2838    ;
  2839   "RTN","PSB VPR",5,0)
  2840    ;
  2841   "RTN","PSB VPR",6,0)
  2842   ADMIN(RESU LTS,PSBVDF N,PSBORDNO ,PSBVADT)  ;
  2843   "RTN","PSB VPR",7,0)
  2844    I $G(PSBV DFN)="" Q  -1
  2845   "RTN","PSB VPR",8,0)
  2846    I $G(PSBO RDNO)="" Q  -2
  2847   "RTN","PSB VPR",9,0)
  2848    K ^TMP("P SB",$J) N  PSBI,A,PSB A,S1,X1,X2 ,X
  2849   "RTN","PSB VPR",10,0)
  2850    I '$G(PSB VADT) D NO W^%DTC S P SBVADT=%
  2851   "RTN","PSB VPR",11,0)
  2852    D GETINFO
  2853   "RTN","PSB VPR",12,0)
  2854    S RESULTS =$O(PSBA(P SBVADT-.00 01)) I 'RE SULTS S X1 =PSBVADT,X 2=1 D C^%D TC S PSBVA DT=X D GET INFO
  2855   "RTN","PSB VPR",13,0)
  2856    S RESULTS =$O(PSBA(P SBVADT-.00 01))
  2857   "RTN","PSB VPR",14,0)
  2858    Q
  2859   "RTN","PSB VPR",15,0)
  2860   GETINFO ;
  2861   "RTN","PSB VPR",16,0)
  2862    I PSBORDN O?.E1"U" D  RPC^PSBVD LTB(,PSBVD FN,"UDTAB" ,PSBVADT)  M ^TMP("PS BVPR",$J)= ^TMP("PSB" ,$J,"UDTAB ")
  2863   "RTN","PSB VPR",17,0)
  2864    I PSBORDN O?.E1"V" F  PSBI="IVT AB","PBTAB " D RPC^PS BVDLTB(,PS BVDFN,PSBI ,$G(PSBVAD T)) M ^TMP ("PSBVPR", $J)=^TMP(" PSB",$J,PS BI)
  2865   "RTN","PSB VPR",18,0)
  2866    S S1=0 F   S S1=$O(^ TMP("PSBVP R",$J,S1))  Q:'S1  D
  2867   "RTN","PSB VPR",19,0)
  2868    . S A=^TM P("PSBVPR" ,$J,S1) I  $P(A,"^")' =PSBVDFN Q
  2869   "RTN","PSB VPR",20,0)
  2870    . I $P(A, "^",2)'=PS BORDNO Q
  2871   "RTN","PSB VPR",21,0)
  2872    . S PSBA( $P(A,"^",1 4))=""
  2873   "RTN","PSB VPR",22,0)
  2874    Q
  2875   "VER")
  2876   8.0^22.0
  2877   **INSTALL  NAME**
  2878   VPR*1.0*3
  2879   "BLD",8470 ,0)
  2880   VPR*1.0*3^ VIRTUAL PA TIENT RECO RD^0^31406 11^y
  2881   "BLD",8470 ,1,0)
  2882   ^9.61A^2^2 ^3130717^^ ^
  2883   "BLD",8470 ,1,1,0)
  2884   The Virtua l Patient  Record (VP R) monitor s a VistA  system for  new data
  2885   "BLD",8470 ,1,2,0)
  2886   and activi ty, and ma kes that d ata availa ble to a s ubscribing  client.
  2887   "BLD",8470 ,4,0)
  2888   ^9.64PA^10 0.98^7
  2889   "BLD",8470 ,4,100.98, 0)
  2890   100.98
  2891   "BLD",8470 ,4,100.98, 222)
  2892   n^n^f^^n^^ y^o^n
  2893   "BLD",8470 ,4,100.98, 223)
  2894  
  2895   "BLD",8470 ,4,100.98, 224)
  2896   I $P(^(0), U,3)="NTX"
  2897   "BLD",8470 ,4,101.41, 0)
  2898   101.41
  2899   "BLD",8470 ,4,101.41, 222)
  2900   n^n^f^^n^^ y^o^n
  2901   "BLD",8470 ,4,101.41, 224)
  2902   I $P(^(0), U)="OR GXM ISC TREATM ENTS"
  2903   "BLD",8470 ,4,560,0)
  2904   560
  2905   "BLD",8470 ,4,560,222 )
  2906   y^y^f^^^^n
  2907   "BLD",8470 ,4,560.1,0 )
  2908   560.1
  2909   "BLD",8470 ,4,560.1,2 22)
  2910   y^y^f^^^^n
  2911   "BLD",8470 ,4,560.11, 0)
  2912   560.11
  2913   "BLD",8470 ,4,560.11, 222)
  2914   y^y^f^^^^n
  2915   "BLD",8470 ,4,561,0)
  2916   561
  2917   "BLD",8470 ,4,561,222 )
  2918   y^y^f^^^^n
  2919   "BLD",8470 ,4,561.2,0 )
  2920   561.2
  2921   "BLD",8470 ,4,561.2,2 22)
  2922   y^y^f
  2923   "BLD",8470 ,4,"B",100 .98,100.98 )
  2924  
  2925   "BLD",8470 ,4,"B",101 .41,101.41 )
  2926  
  2927   "BLD",8470 ,4,"B",560 ,560)
  2928  
  2929   "BLD",8470 ,4,"B",560 .1,560.1)
  2930  
  2931   "BLD",8470 ,4,"B",560 .11,560.11 )
  2932  
  2933   "BLD",8470 ,4,"B",561 ,561)
  2934  
  2935   "BLD",8470 ,4,"B",561 .2,561.2)
  2936  
  2937   "BLD",8470 ,6.3)
  2938   283
  2939   "BLD",8470 ,"ABPKG")
  2940   n
  2941   "BLD",8470 ,"INI")
  2942   PRE^VPRP3I
  2943   "BLD",8470 ,"INIT")
  2944   POST^VPRP3 I
  2945   "BLD",8470 ,"KRN",0)
  2946   ^9.67PA^77 9.2^20
  2947   "BLD",8470 ,"KRN",.4, 0)
  2948   .4
  2949   "BLD",8470 ,"KRN",.40 1,0)
  2950   .401
  2951   "BLD",8470 ,"KRN",.40 2,0)
  2952   .402
  2953   "BLD",8470 ,"KRN",.40 3,0)
  2954   .403
  2955   "BLD",8470 ,"KRN",.5, 0)
  2956   .5
  2957   "BLD",8470 ,"KRN",.84 ,0)
  2958   .84
  2959   "BLD",8470 ,"KRN",3.6 ,0)
  2960   3.6
  2961   "BLD",8470 ,"KRN",3.8 ,0)
  2962   3.8
  2963   "BLD",8470 ,"KRN",9.2 ,0)
  2964   9.2
  2965   "BLD",8470 ,"KRN",9.8 ,0)
  2966   9.8
  2967   "BLD",8470 ,"KRN",9.8 ,"NM",0)
  2968   ^9.68A^103 ^75
  2969   "BLD",8470 ,"KRN",9.8 ,"NM",1,0)
  2970   VPRIDX^^0^ B14476451
  2971   "BLD",8470 ,"KRN",9.8 ,"NM",2,0)
  2972   VPREVNT^^0 ^B10422331 4
  2973   "BLD",8470 ,"KRN",9.8 ,"NM",3,0)
  2974   VPRPATS^^0 ^B44568818
  2975   "BLD",8470 ,"KRN",9.8 ,"NM",4,0)
  2976   VPRSR^^0^B 406288
  2977   "BLD",8470 ,"KRN",9.8 ,"NM",5,0)
  2978   VPRHTTP^^0 ^B14174140
  2979   "BLD",8470 ,"KRN",9.8 ,"NM",6,0)
  2980   VPRCORD^^0 ^B7459309
  2981   "BLD",8470 ,"KRN",9.8 ,"NM",7,0)
  2982   VPRCORD1^^ 0^B1952342 36
  2983   "BLD",8470 ,"KRN",9.8 ,"NM",8,0)
  2984   VPRCORD2^^ 0^B6771688 9
  2985   "BLD",8470 ,"KRN",9.8 ,"NM",9,0)
  2986   VPRCPAT^^0 ^B18789518
  2987   "BLD",8470 ,"KRN",9.8 ,"NM",10,0 )
  2988   VPRCPAT1^^ 0^B7071755
  2989   "BLD",8470 ,"KRN",9.8 ,"NM",11,0 )
  2990   VPRPANEL^^ 0^B9307129
  2991   "BLD",8470 ,"KRN",9.8 ,"NM",12,0 )
  2992   VPRFPTC^^0 ^B14576966
  2993   "BLD",8470 ,"KRN",9.8 ,"NM",13,0 )
  2994   VPRROS2^^0 ^B10651660 0
  2995   "BLD",8470 ,"KRN",9.8 ,"NM",14,0 )
  2996   VPRROS3^^0 ^B86684006
  2997   "BLD",8470 ,"KRN",9.8 ,"NM",15,0 )
  2998   VPRROS4^^0 ^B91302550
  2999   "BLD",8470 ,"KRN",9.8 ,"NM",16,0 )
  3000   VPRROS5^^0 ^B9679013
  3001   "BLD",8470 ,"KRN",9.8 ,"NM",18,0 )
  3002   VPRPRODC^^ 0^B2553308
  3003   "BLD",8470 ,"KRN",9.8 ,"NM",19,0 )
  3004   VPRCRPC^^0 ^B13037791
  3005   "BLD",8470 ,"KRN",9.8 ,"NM",20,0 )
  3006   VPRCRPC1^^ 0^B1151588 51
  3007   "BLD",8470 ,"KRN",9.8 ,"NM",43,0 )
  3008   VPRDX^^1^
  3009   "BLD",8470 ,"KRN",9.8 ,"NM",45,0 )
  3010   VPRCORD3^^ 0^B1513718 65
  3011   "BLD",8470 ,"KRN",9.8 ,"NM",46,0 )
  3012   VPRCORD4^^ 0^B1401280 91
  3013   "BLD",8470 ,"KRN",9.8 ,"NM",47,0 )
  3014   VPRCPRS^^0 ^B4945756
  3015   "BLD",8470 ,"KRN",9.8 ,"NM",49,0 )
  3016   VPRDJ04E^^ 0^B1017070 3
  3017   "BLD",8470 ,"KRN",9.8 ,"NM",50,0 )
  3018   VPRDJ1^^0^ B18149314
  3019   "BLD",8470 ,"KRN",9.8 ,"NM",51,0 )
  3020   VPRDJ2^^0^ B21100510
  3021   "BLD",8470 ,"KRN",9.8 ,"NM",52,0 )
  3022   VPRDJX^^0^ B36169855
  3023   "BLD",8470 ,"KRN",9.8 ,"NM",53,0 )
  3024   VPREASU^^0 ^B59801408
  3025   "BLD",8470 ,"KRN",9.8 ,"NM",54,0 )
  3026   VPREF^^0^B 160851666
  3027   "BLD",8470 ,"KRN",9.8 ,"NM",55,0 )
  3028   VPREFX^^0^ B8552882
  3029   "BLD",8470 ,"KRN",9.8 ,"NM",56,0 )
  3030   VPRENSZ^^0 ^B68594142
  3031   "BLD",8470 ,"KRN",9.8 ,"NM",57,0 )
  3032   VPRENSZ1^^ 0^B1068678 8
  3033   "BLD",8470 ,"KRN",9.8 ,"NM",58,0 )
  3034   VPRMDUTL^^ 0^B5094981 2
  3035   "BLD",8470 ,"KRN",9.8 ,"NM",59,0 )
  3036   VPRPARAM^^ 0^B1543611 3
  3037   "BLD",8470 ,"KRN",9.8 ,"NM",60,0 )
  3038   VPRPXRM^^0 ^B12244143
  3039   "BLD",8470 ,"KRN",9.8 ,"NM",61,0 )
  3040   VPRROS6^^0 ^B26492527
  3041   "BLD",8470 ,"KRN",9.8 ,"NM",62,0 )
  3042   VPRROS7^^0 ^B23838606
  3043   "BLD",8470 ,"KRN",9.8 ,"NM",63,0 )
  3044   VPRTRPC^^0 ^B3739499
  3045   "BLD",8470 ,"KRN",9.8 ,"NM",64,0 )
  3046   VPRTRPC1^^ 0^B4151878 4
  3047   "BLD",8470 ,"KRN",9.8 ,"NM",65,0 )
  3048   VPRDJ09M^^ 0^B1020485 9
  3049   "BLD",8470 ,"KRN",9.8 ,"NM",66,0 )
  3050   VPRYFRP^^0 ^B93175404
  3051   "BLD",8470 ,"KRN",9.8 ,"NM",67,0 )
  3052   VPRYPAR^^0 ^B3971880
  3053   "BLD",8470 ,"KRN",9.8 ,"NM",68,0 )
  3054   VPRDJ^^0^B 33552080
  3055   "BLD",8470 ,"KRN",9.8 ,"NM",70,0 )
  3056   VPRDJ00^^0 ^B82191194
  3057   "BLD",8470 ,"KRN",9.8 ,"NM",71,0 )
  3058   VPRDJ01^^0 ^B41209021
  3059   "BLD",8470 ,"KRN",9.8 ,"NM",72,0 )
  3060   VPRDJ02^^0 ^B65003415
  3061   "BLD",8470 ,"KRN",9.8 ,"NM",73,0 )
  3062   VPRDJ03^^0 ^B54346353
  3063   "BLD",8470 ,"KRN",9.8 ,"NM",74,0 )
  3064   VPRDJ04^^0 ^B48300621
  3065   "BLD",8470 ,"KRN",9.8 ,"NM",75,0 )
  3066   VPRDJ05^^0 ^B78637701
  3067   "BLD",8470 ,"KRN",9.8 ,"NM",77,0 )
  3068   VPRDJ06^^0 ^B58927484
  3069   "BLD",8470 ,"KRN",9.8 ,"NM",78,0 )
  3070   VPRDJ07^^0 ^B21890653
  3071   "BLD",8470 ,"KRN",9.8 ,"NM",79,0 )
  3072   VPRDJ08^^0 ^B69321777
  3073   "BLD",8470 ,"KRN",9.8 ,"NM",80,0 )
  3074   VPRDJ09^^0 ^B39174048
  3075   "BLD",8470 ,"KRN",9.8 ,"NM",81,0 )
  3076   VPRDJ04A^^ 0^B3600734 6
  3077   "BLD",8470 ,"KRN",9.8 ,"NM",82,0 )
  3078   VPRDJ08A^^ 0^B4451787 6
  3079   "BLD",8470 ,"KRN",9.8 ,"NM",83,0 )
  3080   VPRUPD^^0^ B20368971
  3081   "BLD",8470 ,"KRN",9.8 ,"NM",84,0 )
  3082   VPRELAB^^0 ^B5640555
  3083   "BLD",8470 ,"KRN",9.8 ,"NM",85,0 )
  3084   VPRDJFS^^0 ^B54169565
  3085   "BLD",8470 ,"KRN",9.8 ,"NM",86,0 )
  3086   VPRDJFSG^^ 0^B9704933 4
  3087   "BLD",8470 ,"KRN",9.8 ,"NM",87,0 )
  3088   VPRDJFSP^^ 0^B1408223 34
  3089   "BLD",8470 ,"KRN",9.8 ,"NM",88,0 )
  3090   VPRDJFST^^ 0^B4547544 6
  3091   "BLD",8470 ,"KRN",9.8 ,"NM",89,0 )
  3092   VPREFSG^^0 ^B7186739
  3093   "BLD",8470 ,"KRN",9.8 ,"NM",90,0 )
  3094   VPREFSP^^0 ^B44858817
  3095   "BLD",8470 ,"KRN",9.8 ,"NM",91,0 )
  3096   VPREFST^^0 ^B5375002
  3097   "BLD",8470 ,"KRN",9.8 ,"NM",92,0 )
  3098   VPRCAC^^0^ B93748801
  3099   "BLD",8470 ,"KRN",9.8 ,"NM",93,0 )
  3100   VPRUTILS^^ 0^B1865995 6
  3101   "BLD",8470 ,"KRN",9.8 ,"NM",94,0 )
  3102   VPRJSON^^0 ^B11235996
  3103   "BLD",8470 ,"KRN",9.8 ,"NM",95,0 )
  3104   VPRJSOND^^ 0^B7023227 9
  3105   "BLD",8470 ,"KRN",9.8 ,"NM",96,0 )
  3106   VPRJSONE^^ 0^B2434984 5
  3107   "BLD",8470 ,"KRN",9.8 ,"NM",97,0 )
  3108   VPREHL7^^0 ^B3241775
  3109   "BLD",8470 ,"KRN",9.8 ,"NM",99,0 )
  3110   VPRDJFSM^^ 0^B4963941 9
  3111   "BLD",8470 ,"KRN",9.8 ,"NM",100, 0)
  3112   VPRDJ0^^0^ B87535759
  3113   "BLD",8470 ,"KRN",9.8 ,"NM",101, 0)
  3114   VPRDJFSD^^ 0^B4802393
  3115   "BLD",8470 ,"KRN",9.8 ,"NM",102, 0)
  3116   VPRYCSI^^0 ^B16364707
  3117   "BLD",8470 ,"KRN",9.8 ,"NM",103, 0)
  3118   VPRYFRP1^^ 0^B4639822 6
  3119   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCAC",9 2)
  3120  
  3121   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCORD", 6)
  3122  
  3123   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCORD1" ,7)
  3124  
  3125   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCORD2" ,8)
  3126  
  3127   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCORD3" ,45)
  3128  
  3129   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCORD4" ,46)
  3130  
  3131   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCPAT", 9)
  3132  
  3133   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCPAT1" ,10)
  3134  
  3135   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCPRS", 47)
  3136  
  3137   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCRPC", 19)
  3138  
  3139   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRCRPC1" ,20)
  3140  
  3141   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ",68 )
  3142  
  3143   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ0",1 00)
  3144  
  3145   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ00", 70)
  3146  
  3147   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ01", 71)
  3148  
  3149   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ02", 72)
  3150  
  3151   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ03", 73)
  3152  
  3153   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ04", 74)
  3154  
  3155   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ04A" ,81)
  3156  
  3157   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ04E" ,49)
  3158  
  3159   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ05", 75)
  3160  
  3161   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ06", 77)
  3162  
  3163   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ07", 78)
  3164  
  3165   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ08", 79)
  3166  
  3167   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ08A" ,82)
  3168  
  3169   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ09", 80)
  3170  
  3171   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ09M" ,65)
  3172  
  3173   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ1",5 0)
  3174  
  3175   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJ2",5 1)
  3176  
  3177   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJFS", 85)
  3178  
  3179   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJFSD" ,101)
  3180  
  3181   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJFSG" ,86)
  3182  
  3183   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJFSM" ,99)
  3184  
  3185   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJFSP" ,87)
  3186  
  3187   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJFST" ,88)
  3188  
  3189   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDJX",5 2)
  3190  
  3191   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRDX",43 )
  3192  
  3193   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPREASU", 53)
  3194  
  3195   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPREF",54 )
  3196  
  3197   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPREFSG", 89)
  3198  
  3199   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPREFSP", 90)
  3200  
  3201   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPREFST", 91)
  3202  
  3203   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPREFX",5 5)
  3204  
  3205   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPREHL7", 97)
  3206  
  3207   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRELAB", 84)
  3208  
  3209   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRENSZ", 56)
  3210  
  3211   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRENSZ1" ,57)
  3212  
  3213   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPREVNT", 2)
  3214  
  3215   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRFPTC", 12)
  3216  
  3217   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRHTTP", 5)
  3218  
  3219   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRIDX",1 )
  3220  
  3221   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRJSON", 94)
  3222  
  3223   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRJSOND" ,95)
  3224  
  3225   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRJSONE" ,96)
  3226  
  3227   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRMDUTL" ,58)
  3228  
  3229   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRPANEL" ,11)
  3230  
  3231   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRPARAM" ,59)
  3232  
  3233   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRPATS", 3)
  3234  
  3235   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRPRODC" ,18)
  3236  
  3237   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRPXRM", 60)
  3238  
  3239   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRROS2", 13)
  3240  
  3241   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRROS3", 14)
  3242  
  3243   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRROS4", 15)
  3244  
  3245   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRROS5", 16)
  3246  
  3247   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRROS6", 61)
  3248  
  3249   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRROS7", 62)
  3250  
  3251   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRSR",4)
  3252  
  3253   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRTRPC", 63)
  3254  
  3255   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRTRPC1" ,64)
  3256  
  3257   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRUPD",8 3)
  3258  
  3259   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRUTILS" ,93)
  3260  
  3261   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRYCSI", 102)
  3262  
  3263   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRYFRP", 66)
  3264  
  3265   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRYFRP1" ,103)
  3266  
  3267   "BLD",8470 ,"KRN",9.8 ,"NM","B", "VPRYPAR", 67)
  3268  
  3269   "BLD",8470 ,"KRN",19, 0)
  3270   19
  3271   "BLD",8470 ,"KRN",19, "NM",0)
  3272   ^9.68A^15^ 15
  3273   "BLD",8470 ,"KRN",19, "NM",1,0)
  3274   VPR APPOIN TMENTS^^0
  3275   "BLD",8470 ,"KRN",19, "NM",2,0)
  3276   VPR PATIEN T DATA MON ITOR^^0
  3277   "BLD",8470 ,"KRN",19, "NM",3,0)
  3278   VPR UI CON TEXT^^0
  3279   "BLD",8470 ,"KRN",19, "NM",4,0)
  3280   VPR SYNCHR ONIZATION  CONTEXT^^0
  3281   "BLD",8470 ,"KRN",19, "NM",5,0)
  3282   VPR APPLIC ATION PROX Y^^0
  3283   "BLD",8470 ,"KRN",19, "NM",6,0)
  3284   VPR XU EVE NTS^^0
  3285   "BLD",8470 ,"KRN",19, "NM",7,0)
  3286   XU USER AD D^^2
  3287   "BLD",8470 ,"KRN",19, "NM",8,0)
  3288   XU USER CH ANGE^^2
  3289   "BLD",8470 ,"KRN",19, "NM",9,0)
  3290   XU USER TE RMINATE^^2
  3291   "BLD",8470 ,"KRN",19, "NM",10,0)
  3292   VPRM ADD H MP USER^^0
  3293   "BLD",8470 ,"KRN",19, "NM",11,0)
  3294   VPRM EMERG ENCY STOP^ ^0
  3295   "BLD",8470 ,"KRN",19, "NM",12,0)
  3296   VPRM EXTRA CT MONITOR ^^0
  3297   "BLD",8470 ,"KRN",19, "NM",13,0)
  3298   VPRM ADD H MP PATIENT ^^0
  3299   "BLD",8470 ,"KRN",19, "NM",14,0)
  3300   VPRMGR^^0
  3301   "BLD",8470 ,"KRN",19, "NM",15,0)
  3302   VPRM RESTA RT FRESHNE SS^^0
  3303   "BLD",8470 ,"KRN",19, "NM","B"," VPR APPLIC ATION PROX Y",5)
  3304  
  3305   "BLD",8470 ,"KRN",19, "NM","B"," VPR APPOIN TMENTS",1)
  3306  
  3307   "BLD",8470 ,"KRN",19, "NM","B"," VPR PATIEN T DATA MON ITOR",2)
  3308  
  3309   "BLD",8470 ,"KRN",19, "NM","B"," VPR SYNCHR ONIZATION  CONTEXT",4 )
  3310  
  3311   "BLD",8470 ,"KRN",19, "NM","B"," VPR UI CON TEXT",3)
  3312  
  3313   "BLD",8470 ,"KRN",19, "NM","B"," VPR XU EVE NTS",6)
  3314  
  3315   "BLD",8470 ,"KRN",19, "NM","B"," VPRM ADD H MP PATIENT ",13)
  3316  
  3317   "BLD",8470 ,"KRN",19, "NM","B"," VPRM ADD H MP USER",1 0)
  3318  
  3319   "BLD",8470 ,"KRN",19, "NM","B"," VPRM EMERG ENCY STOP" ,11)
  3320  
  3321   "BLD",8470 ,"KRN",19, "NM","B"," VPRM EXTRA CT MONITOR ",12)
  3322  
  3323   "BLD",8470 ,"KRN",19, "NM","B"," VPRM RESTA RT FRESHNE SS",15)
  3324  
  3325   "BLD",8470 ,"KRN",19, "NM","B"," VPRMGR",14 )
  3326  
  3327   "BLD",8470 ,"KRN",19, "NM","B"," XU USER AD D",7)
  3328  
  3329   "BLD",8470 ,"KRN",19, "NM","B"," XU USER CH ANGE",8)
  3330  
  3331   "BLD",8470 ,"KRN",19, "NM","B"," XU USER TE RMINATE",9 )
  3332  
  3333   "BLD",8470 ,"KRN",19. 1,0)
  3334   19.1
  3335   "BLD",8470 ,"KRN",19. 1,"NM",0)
  3336   ^9.68A^2^2
  3337   "BLD",8470 ,"KRN",19. 1,"NM",1,0 )
  3338   VPR EXPERI MENTAL^^0
  3339   "BLD",8470 ,"KRN",19. 1,"NM",2,0 )
  3340   VPR ADMIN^ ^0
  3341   "BLD",8470 ,"KRN",19. 1,"NM","B" ,"VPR ADMI N",2)
  3342  
  3343   "BLD",8470 ,"KRN",19. 1,"NM","B" ,"VPR EXPE RIMENTAL", 1)
  3344  
  3345   "BLD",8470 ,"KRN",101 ,0)
  3346   101
  3347   "BLD",8470 ,"KRN",101 ,"NM",0)
  3348   ^9.68A^40^ 35
  3349   "BLD",8470 ,"KRN",101 ,"NM",1,0)
  3350   VPR APPT E VENTS^^0
  3351   "BLD",8470 ,"KRN",101 ,"NM",2,0)
  3352   VPR DG UPD ATES^^0
  3353   "BLD",8470 ,"KRN",101 ,"NM",3,0)
  3354   VPR INPT E VENTS^^0
  3355   "BLD",8470 ,"KRN",101 ,"NM",4,0)
  3356   VPR PCE EV ENTS^^0
  3357   "BLD",8470 ,"KRN",101 ,"NM",5,0)
  3358   VPR XQOR E VENTS^^0
  3359   "BLD",8470 ,"KRN",101 ,"NM",7,0)
  3360   DG FIELD M ONITOR^^2
  3361   "BLD",8470 ,"KRN",101 ,"NM",8,0)
  3362   DGPM MOVEM ENT EVENTS ^^2
  3363   "BLD",8470 ,"KRN",101 ,"NM",9,0)
  3364   LR7O CH EV SEND OR^^2
  3365   "BLD",8470 ,"KRN",101 ,"NM",10,0 )
  3366   PS EVSEND  OR^^2
  3367   "BLD",8470 ,"KRN",101 ,"NM",11,0 )
  3368   PXK VISIT  DATA EVENT ^^2
  3369   "BLD",8470 ,"KRN",101 ,"NM",12,0 )
  3370   RA EVSEND  OR^^2
  3371   "BLD",8470 ,"KRN",101 ,"NM",13,0 )
  3372   SDAM APPOI NTMENT EVE NTS^^2
  3373   "BLD",8470 ,"KRN",101 ,"NM",14,0 )
  3374   VPR GMRA E VENTS^^0
  3375   "BLD",8470 ,"KRN",101 ,"NM",15,0 )
  3376   GMRA ENTER ED IN ERRO R^^2
  3377   "BLD",8470 ,"KRN",101 ,"NM",16,0 )
  3378   GMRA SIGN- OFF ON DAT A^^2
  3379   "BLD",8470 ,"KRN",101 ,"NM",17,0 )
  3380   GMRC EVSEN D OR^^2
  3381   "BLD",8470 ,"KRN",101 ,"NM",20,0 )
  3382   OR EVSEND  GMRC^^2
  3383   "BLD",8470 ,"KRN",101 ,"NM",23,0 )
  3384   OR EVSEND  LRCH^^2
  3385   "BLD",8470 ,"KRN",101 ,"NM",24,0 )
  3386   OR EVSEND  ORG^^2
  3387   "BLD",8470 ,"KRN",101 ,"NM",25,0 )
  3388   OR EVSEND  PS^^2
  3389   "BLD",8470 ,"KRN",101 ,"NM",26,0 )
  3390   OR EVSEND  RA^^2
  3391   "BLD",8470 ,"KRN",101 ,"NM",27,0 )
  3392   GMPL EVENT ^^2
  3393   "BLD",8470 ,"KRN",101 ,"NM",28,0 )
  3394   VPR GMPL E VENT^^0
  3395   "BLD",8470 ,"KRN",101 ,"NM",29,0 )
  3396   VPR NA EVE NTS^^0
  3397   "BLD",8470 ,"KRN",101 ,"NM",30,0 )
  3398   MDC OBSERV ATION UPDA TE^^2
  3399   "BLD",8470 ,"KRN",101 ,"NM",31,0 )
  3400   OR EVSEND  FH^^2
  3401   "BLD",8470 ,"KRN",101 ,"NM",32,0 )
  3402   VPR MDC EV ENT^^0
  3403   "BLD",8470 ,"KRN",101 ,"NM",33,0 )
  3404   FH EVSEND  OR^^2
  3405   "BLD",8470 ,"KRN",101 ,"NM",34,0 )
  3406   OR EVSEND  VPR^^2
  3407   "BLD",8470 ,"KRN",101 ,"NM",35,0 )
  3408   VPR ADT-A0 4 CLIENT^^ 0
  3409   "BLD",8470 ,"KRN",101 ,"NM",36,0 )
  3410   VAFC ADT-A 04 SERVER^ ^2
  3411   "BLD",8470 ,"KRN",101 ,"NM",37,0 )
  3412   VPR PSB EV ENTS^^0
  3413   "BLD",8470 ,"KRN",101 ,"NM",38,0 )
  3414   PSB EVSEND  VPR^^2
  3415   "BLD",8470 ,"KRN",101 ,"NM",39,0 )
  3416   VPR ADT-A0 8 CLIENT^^ 0
  3417   "BLD",8470 ,"KRN",101 ,"NM",40,0 )
  3418   VAFC ADT-A 08 SERVER^ ^2
  3419   "BLD",8470 ,"KRN",101 ,"NM","B", "DG FIELD  MONITOR",7 )
  3420  
  3421   "BLD",8470 ,"KRN",101 ,"NM","B", "DGPM MOVE MENT EVENT S",8)
  3422  
  3423   "BLD",8470 ,"KRN",101 ,"NM","B", "FH EVSEND  OR",33)
  3424  
  3425   "BLD",8470 ,"KRN",101 ,"NM","B", "GMPL EVEN T",27)
  3426  
  3427   "BLD",8470 ,"KRN",101 ,"NM","B", "GMRA ENTE RED IN ERR OR",15)
  3428  
  3429   "BLD",8470 ,"KRN",101 ,"NM","B", "GMRA SIGN -OFF ON DA TA",16)
  3430  
  3431   "BLD",8470 ,"KRN",101 ,"NM","B", "GMRC EVSE ND OR",17)
  3432  
  3433   "BLD",8470 ,"KRN",101 ,"NM","B", "LR7O CH E VSEND OR", 9)
  3434  
  3435   "BLD",8470 ,"KRN",101 ,"NM","B", "MDC OBSER VATION UPD ATE",30)
  3436  
  3437   "BLD",8470 ,"KRN",101 ,"NM","B", "OR EVSEND  FH",31)
  3438  
  3439   "BLD",8470 ,"KRN",101 ,"NM","B", "OR EVSEND  GMRC",20)
  3440  
  3441   "BLD",8470 ,"KRN",101 ,"NM","B", "OR EVSEND  LRCH",23)
  3442  
  3443   "BLD",8470 ,"KRN",101 ,"NM","B", "OR EVSEND  ORG",24)
  3444  
  3445   "BLD",8470 ,"KRN",101 ,"NM","B", "OR EVSEND  PS",25)
  3446  
  3447   "BLD",8470 ,"KRN",101 ,"NM","B", "OR EVSEND  RA",26)
  3448  
  3449   "BLD",8470 ,"KRN",101 ,"NM","B", "OR EVSEND  VPR",34)
  3450  
  3451   "BLD",8470 ,"KRN",101 ,"NM","B", "PS EVSEND  OR",10)
  3452  
  3453   "BLD",8470 ,"KRN",101 ,"NM","B", "PSB EVSEN D VPR",38)
  3454  
  3455   "BLD",8470 ,"KRN",101 ,"NM","B", "PXK VISIT  DATA EVEN T",11)
  3456  
  3457   "BLD",8470 ,"KRN",101 ,"NM","B", "RA EVSEND  OR",12)
  3458  
  3459   "BLD",8470 ,"KRN",101 ,"NM","B", "SDAM APPO INTMENT EV ENTS",13)
  3460  
  3461   "BLD",8470 ,"KRN",101 ,"NM","B", "VAFC ADT- A04 SERVER ",36)
  3462  
  3463   "BLD",8470 ,"KRN",101 ,"NM","B", "VAFC ADT- A08 SERVER ",40)
  3464  
  3465   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR ADT-A 04 CLIENT" ,35)
  3466  
  3467   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR ADT-A 08 CLIENT" ,39)
  3468  
  3469   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR APPT  EVENTS",1)
  3470  
  3471   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR DG UP DATES",2)
  3472  
  3473   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR GMPL  EVENT",28)
  3474  
  3475   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR GMRA  EVENTS",14 )
  3476  
  3477   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR INPT  EVENTS",3)
  3478  
  3479   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR MDC E VENT",32)
  3480  
  3481   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR NA EV ENTS",29)
  3482  
  3483   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR PCE E VENTS",4)
  3484  
  3485   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR PSB E VENTS",37)
  3486  
  3487   "BLD",8470 ,"KRN",101 ,"NM","B", "VPR XQOR  EVENTS",5)
  3488  
  3489   "BLD",8470 ,"KRN",409 .61,0)
  3490   409.61
  3491   "BLD",8470 ,"KRN",409 .61,"NM",0 )
  3492   ^9.68A^^
  3493   "BLD",8470 ,"KRN",771 ,0)
  3494   771
  3495   "BLD",8470 ,"KRN",771 ,"NM",0)
  3496   ^9.68A^1^1
  3497   "BLD",8470 ,"KRN",771 ,"NM",1,0)
  3498   VPR HL7^^0
  3499   "BLD",8470 ,"KRN",771 ,"NM","B", "VPR HL7", 1)
  3500  
  3501   "BLD",8470 ,"KRN",779 .2,0)
  3502   779.2
  3503   "BLD",8470 ,"KRN",870 ,0)
  3504   870
  3505   "BLD",8470 ,"KRN",898 9.51,0)
  3506   8989.51
  3507   "BLD",8470 ,"KRN",898 9.51,"NM", 0)
  3508   ^9.68A^4^4
  3509   "BLD",8470 ,"KRN",898 9.51,"NM", 1,0)
  3510   VPR LOCATI ONS^^0
  3511   "BLD",8470 ,"KRN",898 9.51,"NM", 2,0)
  3512   VPR TASK W AIT TIME^^ 0
  3513   "BLD",8470 ,"KRN",898 9.51,"NM", 3,0)
  3514   VPR PARAME TERS^^0
  3515   "BLD",8470 ,"KRN",898 9.51,"NM", 4,0)
  3516   VPR CPRS P ATH^^0
  3517   "BLD",8470 ,"KRN",898 9.51,"NM", "B","VPR C PRS PATH", 4)
  3518  
  3519   "BLD",8470 ,"KRN",898 9.51,"NM", "B","VPR L OCATIONS", 1)
  3520  
  3521   "BLD",8470 ,"KRN",898 9.51,"NM", "B","VPR P ARAMETERS" ,3)
  3522  
  3523   "BLD",8470 ,"KRN",898 9.51,"NM", "B","VPR T ASK WAIT T IME",2)
  3524  
  3525   "BLD",8470 ,"KRN",898 9.52,0)
  3526   8989.52
  3527   "BLD",8470 ,"KRN",899 4,0)
  3528   8994
  3529   "BLD",8470 ,"KRN",899 4,"NM",0)
  3530   ^9.68A^28^ 27
  3531   "BLD",8470 ,"KRN",899 4,"NM",1,0 )
  3532   VPR APPOIN TMENTS^^0
  3533   "BLD",8470 ,"KRN",899 4,"NM",2,0 )
  3534   VPR INPATI ENTS^^0
  3535   "BLD",8470 ,"KRN",899 4,"NM",3,0 )
  3536   VPR SUBSCR IBE^^0
  3537   "BLD",8470 ,"KRN",899 4,"NM",4,0 )
  3538   VPRCORD RP C^^0
  3539   "BLD",8470 ,"KRN",899 4,"NM",5,0 )
  3540   VPRCPAT RP C^^0
  3541   "BLD",8470 ,"KRN",899 4,"NM",7,0 )
  3542   VPRFPTC CH KS^^0
  3543   "BLD",8470 ,"KRN",899 4,"NM",8,0 )
  3544   VPRFPTC LO G^^0
  3545   "BLD",8470 ,"KRN",899 4,"NM",9,0 )
  3546   VPR ROSTER  PATIENTS^ ^0
  3547   "BLD",8470 ,"KRN",899 4,"NM",10, 0)
  3548   VPR ROSTER S^^0
  3549   "BLD",8470 ,"KRN",899 4,"NM",11, 0)
  3550   VPR UPDATE  ROSTER^^0
  3551   "BLD",8470 ,"KRN",899 4,"NM",12, 0)
  3552   VPR PREVIE W ROSTER^^ 0
  3553   "BLD",8470 ,"KRN",899 4,"NM",13, 0)
  3554   VPR GET SO URCE^^0
  3555   "BLD",8470 ,"KRN",899 4,"NM",14, 0)
  3556   VPR DELETE  ROSTER^^0
  3557   "BLD",8470 ,"KRN",899 4,"NM",15, 0)
  3558   VPRCRPC RP C^^0
  3559   "BLD",8470 ,"KRN",899 4,"NM",16, 0)
  3560   VPR DELETE  OBJECT^^0
  3561   "BLD",8470 ,"KRN",899 4,"NM",17, 0)
  3562   VPR GET OB JECT^^0
  3563   "BLD",8470 ,"KRN",899 4,"NM",18, 0)
  3564   VPR GET OP ERATIONAL  DATA^^0
  3565   "BLD",8470 ,"KRN",899 4,"NM",19, 0)
  3566   VPR GET RO STER LIST^ ^0
  3567   "BLD",8470 ,"KRN",899 4,"NM",20, 0)
  3568   VPR PUT OB JECT^^0
  3569   "BLD",8470 ,"KRN",899 4,"NM",21, 0)
  3570   VPR PUT PA TIENT DATA ^^0
  3571   "BLD",8470 ,"KRN",899 4,"NM",22, 0)
  3572   VPR GET RE FERENCE DA TA^^0
  3573   "BLD",8470 ,"KRN",899 4,"NM",23, 0)
  3574   VPR SUBSCR IBE ROSTER S^^0
  3575   "BLD",8470 ,"KRN",899 4,"NM",24, 0)
  3576   VPRCPRS RP C^^0
  3577   "BLD",8470 ,"KRN",899 4,"NM",25, 0)
  3578   VPRCRPC RP CCHAIN^^0
  3579   "BLD",8470 ,"KRN",899 4,"NM",26, 0)
  3580   VPR PUT DE MOGRAPHICS ^^0
  3581   "BLD",8470 ,"KRN",899 4,"NM",27, 0)
  3582   VPRDJFS AP I^^0
  3583   "BLD",8470 ,"KRN",899 4,"NM",28, 0)
  3584   VPRDJFS DE LSUB^^0
  3585   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR APPO INTMENTS", 1)
  3586  
  3587   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR DELE TE OBJECT" ,16)
  3588  
  3589   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR DELE TE ROSTER" ,14)
  3590  
  3591   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR GET  OBJECT",17 )
  3592  
  3593   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR GET  OPERATIONA L DATA",18 )
  3594  
  3595   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR GET  REFERENCE  DATA",22)
  3596  
  3597   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR GET  ROSTER LIS T",19)
  3598  
  3599   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR GET  SOURCE",13 )
  3600  
  3601   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR INPA TIENTS",2)
  3602  
  3603   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR PREV IEW ROSTER ",12)
  3604  
  3605   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR PUT  DEMOGRAPHI CS",26)
  3606  
  3607   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR PUT  OBJECT",20 )
  3608  
  3609   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR PUT  PATIENT DA TA",21)
  3610  
  3611   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR ROST ER PATIENT S",9)
  3612  
  3613   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR ROST ERS",10)
  3614  
  3615   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR SUBS CRIBE",3)
  3616  
  3617   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR SUBS CRIBE ROST ERS",23)
  3618  
  3619   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPR UPDA TE ROSTER" ,11)
  3620  
  3621   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRCORD  RPC",4)
  3622  
  3623   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRCPAT  RPC",5)
  3624  
  3625   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRCPRS  RPC",24)
  3626  
  3627   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRCRPC  RPC",15)
  3628  
  3629   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRCRPC  RPCCHAIN", 25)
  3630  
  3631   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRDJFS  API",27)
  3632  
  3633   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRDJFS  DELSUB",28 )
  3634  
  3635   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRFPTC  CHKS",7)
  3636  
  3637   "BLD",8470 ,"KRN",899 4,"NM","B" ,"VPRFPTC  LOG",8)
  3638  
  3639   "BLD",8470 ,"KRN","B" ,.4,.4)
  3640  
  3641   "BLD",8470 ,"KRN","B" ,.401,.401 )
  3642  
  3643   "BLD",8470 ,"KRN","B" ,.402,.402 )
  3644  
  3645   "BLD",8470 ,"KRN","B" ,.403,.403 )
  3646  
  3647   "BLD",8470 ,"KRN","B" ,.5,.5)
  3648  
  3649   "BLD",8470 ,"KRN","B" ,.84,.84)
  3650  
  3651   "BLD",8470 ,"KRN","B" ,3.6,3.6)
  3652  
  3653   "BLD",8470 ,"KRN","B" ,3.8,3.8)
  3654  
  3655   "BLD",8470 ,"KRN","B" ,9.2,9.2)
  3656  
  3657   "BLD",8470 ,"KRN","B" ,9.8,9.8)
  3658  
  3659   "BLD",8470 ,"KRN","B" ,19,19)
  3660  
  3661   "BLD",8470 ,"KRN","B" ,19.1,19.1 )
  3662  
  3663   "BLD",8470 ,"KRN","B" ,101,101)
  3664  
  3665   "BLD",8470 ,"KRN","B" ,409.61,40 9.61)
  3666  
  3667   "BLD",8470 ,"KRN","B" ,771,771)
  3668  
  3669   "BLD",8470 ,"KRN","B" ,779.2,779 .2)
  3670  
  3671   "BLD",8470 ,"KRN","B" ,870,870)
  3672  
  3673   "BLD",8470 ,"KRN","B" ,8989.51,8 989.51)
  3674  
  3675   "BLD",8470 ,"KRN","B" ,8989.52,8 989.52)
  3676  
  3677   "BLD",8470 ,"KRN","B" ,8994,8994 )
  3678  
  3679   "BLD",8470 ,"PRE")
  3680  
  3681   "BLD",8470 ,"QUES",0)
  3682   ^9.62^^
  3683   "BLD",8470 ,"REQB",0)
  3684   ^9.611^4^2
  3685   "BLD",8470 ,"REQB",3, 0)
  3686   SD*5.3*575 ^2
  3687   "BLD",8470 ,"REQB",4, 0)
  3688   VPR*1.0*2^ 2
  3689   "BLD",8470 ,"REQB","B ","SD*5.3* 575",3)
  3690  
  3691   "BLD",8470 ,"REQB","B ","VPR*1.0 *2",4)
  3692  
  3693   "DATA",100 .98,67,0)
  3694   TREATMENTS ^Treatment s^NTX
  3695   "DATA",101 .41,15917, 0)
  3696   OR GXMISC  TREATMENTS ^Nursing T reatment O rder^^D^67 ^1^170^1^
  3697   "DATA",101 .41,15917, 5)
  3698   ^^^Nursing  Treatment ^^^^
  3699   "DATA",101 .41,15917, 10,0)
  3700   ^101.412IA ^5^5
  3701   "DATA",101 .41,15917, 10,1,0)
  3702   1^4^^Treat ment: ^^1^ ^^^S.NTX
  3703   "DATA",101 .41,15917, 10,1,1)
  3704   Enter a tr eatment it em.
  3705   "DATA",101 .41,15917, 10,1,2)
  3706   1
  3707   "DATA",101 .41,15917, 10,1,4)
  3708   I $$ACTIVE ^ORDD43(Y)
  3709   "DATA",101 .41,15917, 10,1,6)
  3710   N IDX,SCR  S IDX=$G(O RDIALOG(PR OMPT,"D")) ,SCR=$G(OR DIALOG(PRO MPT,"S"))  D XHELP^OR DD43(IDX,S CR)
  3711   "DATA",101 .41,15917, 10,1,10)
  3712   N OI S OI= +$G(ORDIAL OG(PROMPT, INST)) D:O I ORDMSG^O RCD(OI)
  3713   "DATA",101 .41,15917, 10,1,"W")
  3714   cboNursing
  3715   "DATA",101 .41,15917, 10,2,0)
  3716   2^19^^Inst ructions:  ^^^^^C
  3717   "DATA",101 .41,15917, 10,2,1)
  3718   Enter the  instructio ns for thi s order, u p to 240 c haracters  of text.
  3719   "DATA",101 .41,15917, 10,2,2)
  3720   2^^^^^1
  3721   "DATA",101 .41,15917, 10,3,0)
  3722   4^6^^^^1^^ 1^RCW
  3723   "DATA",101 .41,15917, 10,3,1)
  3724   Enter the  date/time  to begin t his order.
  3725   "DATA",101 .41,15917, 10,3,7)
  3726   S Y="NOW"
  3727   "DATA",101 .41,15917, 10,4,0)
  3728   5^24^^^^^^ ^RCW
  3729   "DATA",101 .41,15917, 10,4,1)
  3730   Enter the  date/time  to end thi s order.
  3731   "DATA",101 .41,15917, 10,4,5)
  3732   I $$FTDCOM P^ORCD("ST ART DATE/T IME","STOP  DATE/TIME ",">") K D ONE W $C(7 ),!,"Canno t end befo re start d ate/time!" ,!
  3733   "DATA",101 .41,15917, 10,5,0)
  3734   3^29^^^^^^ ^^
  3735   "DATA",101 .41,15917, 10,5,1)
  3736   ^
  3737   "DATA",101 .41,15917, 10,5,2)
  3738   3
  3739   "DATA",101 .41,15917, 99)
  3740   63349,2442
  3741   "FIA",100. 98)
  3742   DISPLAY GR OUP
  3743   "FIA",100. 98,0)
  3744   ^ORD(100.9 8,
  3745   "FIA",100. 98,0,0)
  3746   100.98I
  3747   "FIA",100. 98,0,1)
  3748   n^n^f^^n^^ y^o^n
  3749   "FIA",100. 98,0,10)
  3750  
  3751   "FIA",100. 98,0,11)
  3752   I $P(^(0), U,3)="NTX"
  3753   "FIA",100. 98,0,"RLRO ")
  3754  
  3755   "FIA",100. 98,0,"VR")
  3756   1.0^VPR
  3757   "FIA",100. 98,100.98)
  3758   0
  3759   "FIA",100. 98,100.981 )
  3760   0
  3761   "FIA",101. 41)
  3762   ORDER DIAL OG
  3763   "FIA",101. 41,0)
  3764   ^ORD(101.4 1,
  3765   "FIA",101. 41,0,0)
  3766   101.41I
  3767   "FIA",101. 41,0,1)
  3768   n^n^f^^n^^ y^o^n
  3769   "FIA",101. 41,0,10)
  3770  
  3771   "FIA",101. 41,0,11)
  3772   I $P(^(0), U)="OR GXM ISC TREATM ENTS"
  3773   "FIA",101. 41,0,"RLRO ")
  3774  
  3775   "FIA",101. 41,0,"VR")
  3776   1.0^VPR
  3777   "FIA",101. 41,101.41)
  3778   0
  3779   "FIA",101. 41,101.411 )
  3780   0
  3781   "FIA",101. 41,101.412 )
  3782   0
  3783   "FIA",101. 41,101.412 18)
  3784   0
  3785   "FIA",101. 41,101.415 )
  3786   0
  3787   "FIA",101. 41,101.416 )
  3788   0
  3789   "FIA",101. 41,101.416 2)
  3790   0
  3791   "FIA",560)
  3792   VPR SUBSCR IPTION
  3793   "FIA",560, 0)
  3794   ^VPR(560,
  3795   "FIA",560, 0,0)
  3796   560
  3797   "FIA",560, 0,1)
  3798   y^y^f^^^^n
  3799   "FIA",560, 0,10)
  3800  
  3801   "FIA",560, 0,11)
  3802  
  3803   "FIA",560, 0,"RLRO")
  3804  
  3805   "FIA",560, 0,"VR")
  3806   1.0^VPR
  3807   "FIA",560, 560)
  3808   0
  3809   "FIA",560, 560.01)
  3810   0
  3811   "FIA",560, 560.02)
  3812   0
  3813   "FIA",560. 1)
  3814   VPR PATIEN T OBJECT
  3815   "FIA",560. 1,0)
  3816   ^VPR(560.1 ,
  3817   "FIA",560. 1,0,0)
  3818   560.1
  3819   "FIA",560. 1,0,1)
  3820   y^y^f^^^^n
  3821   "FIA",560. 1,0,10)
  3822  
  3823   "FIA",560. 1,0,11)
  3824  
  3825   "FIA",560. 1,0,"RLRO" )
  3826  
  3827   "FIA",560. 1,0,"VR")
  3828   1.0^VPR
  3829   "FIA",560. 1,560.1)
  3830   0
  3831   "FIA",560. 1,560.101)
  3832   0
  3833   "FIA",560. 11)
  3834   VPR OBJECT
  3835   "FIA",560. 11,0)
  3836   ^VPR(560.1 1,
  3837   "FIA",560. 11,0,0)
  3838   560.11
  3839   "FIA",560. 11,0,1)
  3840   y^y^f^^^^n
  3841   "FIA",560. 11,0,10)
  3842  
  3843   "FIA",560. 11,0,11)
  3844  
  3845   "FIA",560. 11,0,"RLRO ")
  3846  
  3847   "FIA",560. 11,0,"VR")
  3848   1.0^VPR
  3849   "FIA",560. 11,560.11)
  3850   0
  3851   "FIA",560. 11,560.111 )
  3852   0
  3853   "FIA",561)
  3854   VPR PANEL
  3855   "FIA",561, 0)
  3856   ^VPRPANEL(
  3857   "FIA",561, 0,0)
  3858   561P
  3859   "FIA",561, 0,1)
  3860   y^y^f^^^^n
  3861   "FIA",561, 0,10)
  3862  
  3863   "FIA",561, 0,11)
  3864  
  3865   "FIA",561, 0,"RLRO")
  3866  
  3867   "FIA",561, 0,"VR")
  3868   1.0^VPR
  3869   "FIA",561, 561)
  3870   0
  3871   "FIA",561, 561.05)
  3872   0
  3873   "FIA",561. 2)
  3874   VPROSTER
  3875   "FIA",561. 2,0)
  3876   ^VPROSTER(
  3877   "FIA",561. 2,0,0)
  3878   561.2
  3879   "FIA",561. 2,0,1)
  3880   y^y^f
  3881   "FIA",561. 2,0,10)
  3882  
  3883   "FIA",561. 2,0,11)
  3884  
  3885   "FIA",561. 2,0,"RLRO" )
  3886  
  3887   "FIA",561. 2,0,"VR")
  3888   1.0^VPR
  3889   "FIA",561. 2,561.2)
  3890   0
  3891   "FIA",561. 2,561.21)
  3892   0
  3893   "FIA",561. 2,561.23)
  3894   0
  3895   "INI")
  3896   PRE^VPRP3I
  3897   "INIT")
  3898   POST^VPRP3 I
  3899   "IX",101.4 1,101.41," B",0)
  3900   101.41^B^R egular B i ndex using  full fiel d length^R ^^F^IR^I^1 01.41^^^^^ LS
  3901   "IX",101.4 1,101.41," B",1)
  3902   S ^ORD(101 .41,"B",$E (X,1,63),D A)=""
  3903   "IX",101.4 1,101.41," B",2)
  3904   K ^ORD(101 .41,"B",$E (X,1,63),D A)
  3905   "IX",101.4 1,101.41," B",2.5)
  3906   K ^ORD(101 .41,"B")
  3907   "IX",101.4 1,101.41," B",11.1,0)
  3908   ^.114IA^1^ 1
  3909   "IX",101.4 1,101.41," B",11.1,1, 0)
  3910   1^F^101.41 ^.01^63^1^ F
  3911   "IX",560,5 60,"ADFN", 0)
  3912   560^ADFN^P atients to  track in  the Data M onitor^MU^ ^R^IR^W^56 0.01^^^^^S
  3913   "IX",560,5 60,"ADFN", 1)
  3914   D VPRSET^V PRDJFS(.DA ,.X)
  3915   "IX",560,5 60,"ADFN", 1.4)
  3916   S X=0 I +X (1)>0 S X= 1
  3917   "IX",560,5 60,"ADFN", 2)
  3918   D VPRKILL^ VPRDJFS(.D A,.X)
  3919   "IX",560,5 60,"ADFN", 2.4)
  3920   S X=0 I X( 1)'="" S X =1
  3921   "IX",560,5 60,"ADFN", 2.5)
  3922   K ^VPR(560 ,"AITEM")
  3923   "IX",560,5 60,"ADFN", 11.1,0)
  3924   ^.114IA^2^ 2
  3925   "IX",560,5 60,"ADFN", 11.1,1,0)
  3926   1^F^560.01 ^.01^^1^F
  3927   "IX",560,5 60,"ADFN", 11.1,2,0)
  3928   2^F^560.01 ^2^^^F
  3929   "IX",560,5 60,"AITEM" ,0)
  3930   560^AITEM^ AITEM TEST ^MU^^F^IR^ I^560^^^^^ A
  3931   "IX",560,5 60,"AITEM" ,1)
  3932   D VPROSET^ VPRDJFS(DA ,X)
  3933   "IX",560,5 60,"AITEM" ,1.4)
  3934   I X(1)'=""
  3935   "IX",560,5 60,"AITEM" ,2)
  3936   D VPROKILL ^VPRDJFS(D A)
  3937   "IX",560,5 60,"AITEM" ,2.4)
  3938   I X(1)'=""
  3939   "IX",560,5 60,"AITEM" ,2.5)
  3940   K ^VPR(560 ,"AITEM")
  3941   "IX",560,5 60,"AITEM" ,11.1,0)
  3942   ^.114IA^1^ 1
  3943   "IX",560,5 60,"AITEM" ,11.1,1,0)
  3944   1^F^560^.0 3^^^F
  3945   "IX",560,5 60,"AITEM" ,11.1,1,3)
  3946  
  3947   "IX",560,5 60,"AROS", 0)
  3948   560^AROS^R osters to  track in t he Data Mo nitor^MU^^ R^IR^W^560 .02^^^^^S
  3949   "IX",560,5 60,"AROS", 1)
  3950   S:X2(2) ^V PR(560,"AR OS",X,DA(1 ))=""
  3951   "IX",560,5 60,"AROS", 2)
  3952   K:X1(2) ^V PR(560,"AR OS",X,DA(1 ))
  3953   "IX",560,5 60,"AROS", 2.5)
  3954   K ^VPR(560 ,"AROS")
  3955   "IX",560,5 60,"AROS", 11.1,0)
  3956   ^.114IA^2^ 2
  3957   "IX",560,5 60,"AROS", 11.1,1,0)
  3958   1^F^560.02 ^.01^^1^F
  3959   "IX",560,5 60,"AROS", 11.1,1,3)
  3960  
  3961   "IX",560,5 60,"AROS", 11.1,2,0)
  3962   2^F^560.02 ^2^^2^
  3963   "IX",560,5 60,"AROS", 11.1,2,3)
  3964  
  3965   "IX",560,5 60.01,"AP" ,0)
  3966   560.01^AP^ Subscribed  patients  by server  not yet in itialized. ^R^^R^IR^I ^560.01^^^ ^^S
  3967   "IX",560,5 60.01,"AP" ,.1,0)
  3968   ^^6^6^3140 521^
  3969   "IX",560,5 60.01,"AP" ,.1,1,0)
  3970   This index  lists the  patients  who are no t yet init ialized:
  3971   "IX",560,5 60.01,"AP" ,.1,2,0)
  3972    
  3973   "IX",560,5 60.01,"AP" ,.1,3,0)
  3974     SERVER_I EN, "AP",  STATUS, ST ATUS TIME,  DFN
  3975   "IX",560,5 60.01,"AP" ,.1,4,0)
  3976    
  3977   "IX",560,5 60.01,"AP" ,.1,5,0)
  3978   Patients w ith an ini tialized s tatus (STA TUS = 2) d o not appe ar in this  
  3979   "IX",560,5 60.01,"AP" ,.1,6,0)
  3980   index.
  3981   "IX",560,5 60.01,"AP" ,1)
  3982   S ^VPR(560 ,DA(1),1," AP",X(1),X (2),DA)=""
  3983   "IX",560,5 60.01,"AP" ,1.4)
  3984   S X=(+X2(1 )<2)
  3985   "IX",560,5 60.01,"AP" ,2)
  3986   K ^VPR(560 ,DA(1),1," AP",X(1),X (2),DA)
  3987   "IX",560,5 60.01,"AP" ,2.5)
  3988   K ^VPR(560 ,DA(1),1," AP")
  3989   "IX",560,5 60.01,"AP" ,11.1,0)
  3990   ^.114IA^2^ 2
  3991   "IX",560,5 60.01,"AP" ,11.1,1,0)
  3992   1^F^560.01 ^2^^1^F
  3993   "IX",560,5 60.01,"AP" ,11.1,2,0)
  3994   2^F^560.01 ^3^^2^F
  3995   "IX",560.1 ,560.1,"C" ,0)
  3996   560.1^C^In dex by pat ient, coll ection^R^^ R^IR^I^560 .1^^^^^LS
  3997   "IX",560.1 ,560.1,"C" ,1)
  3998   S ^VPR(560 .1,"C",X(1 ),X(2),DA) =""
  3999   "IX",560.1 ,560.1,"C" ,2)
  4000   K ^VPR(560 .1,"C",X(1 ),X(2),DA)
  4001   "IX",560.1 ,560.1,"C" ,2.5)
  4002   K ^VPR(560 .1,"C")
  4003   "IX",560.1 ,560.1,"C" ,11.1,0)
  4004   ^.114IA^2^ 2
  4005   "IX",560.1 ,560.1,"C" ,11.1,1,0)
  4006   1^F^560.1^ .02^^1^F
  4007   "IX",560.1 ,560.1,"C" ,11.1,1,3)
  4008  
  4009   "IX",560.1 ,560.1,"C" ,11.1,2,0)
  4010   2^F^560.1^ .03^^2^F
  4011   "IX",560.1 ,560.1,"C" ,11.1,2,3)
  4012  
  4013   "IX",561.2 ,561.21,"A C",0)
  4014   561.21^AC^ SORT BY SE QUENCE^R^^ F^IR^I^561 .21^^^^^S
  4015   "IX",561.2 ,561.21,"A C",1)
  4016   Q
  4017   "IX",561.2 ,561.21,"A C",2)
  4018   Q
  4019   "KRN",19,9 027,-1)
  4020   2^9
  4021   "KRN",19,9 027,0)
  4022   XU USER TE RMINATE^Us er termina te event^^ X^10000000 020^^^^^^^ 163^y^1^^^
  4023   "KRN",19,9 027,10,0)
  4024   ^19.01IP^8 ^8
  4025   "KRN",19,9 027,10,8,0 )
  4026   14101
  4027   "KRN",19,9 027,10,8," ^")
  4028   VPR XU EVE NTS
  4029   "KRN",19,9 027,"U")
  4030   USER TERMI NATE EVENT
  4031   "KRN",19,1 2365,-1)
  4032   2^7
  4033   "KRN",19,1 2365,0)
  4034   XU USER AD D^New User  Event^^X^ 1000000002 0^^^^^^^16 3^y^1
  4035   "KRN",19,1 2365,10,0)
  4036   ^19.01IP^2 ^2
  4037   "KRN",19,1 2365,10,2, 0)
  4038   14101
  4039   "KRN",19,1 2365,10,2, "^")
  4040   VPR XU EVE NTS
  4041   "KRN",19,1 2365,"U")
  4042   NEW USER E VENT
  4043   "KRN",19,1 2366,-1)
  4044   2^8
  4045   "KRN",19,1 2366,0)
  4046   XU USER CH ANGE^User  Change Eve nt^^X^1000 0000020^^^ ^^^^163^y^ 1
  4047   "KRN",19,1 2366,10,0)
  4048   ^19.01IP^2 ^2
  4049   "KRN",19,1 2366,10,2, 0)
  4050   14101
  4051   "KRN",19,1 2366,10,2, "^")
  4052   VPR XU EVE NTS
  4053   "KRN",19,1 2366,"U")
  4054   USER CHANG E EVENT
  4055   "KRN",19,1 3996,-1)
  4056   0^1
  4057   "KRN",19,1 3996,0)
  4058   VPR APPOIN TMENTS^Ret urn list o f tomorrow 's patient s^^A^^^^^^ ^^VIRTUAL  PATIENT RE CORD^^1
  4059   "KRN",19,1 3996,1,0)
  4060   ^^3^3^3110 406^
  4061   "KRN",19,1 3996,1,1,0 )
  4062   This optio n is inten ded to be  scheduled  to run nig htly, to n otify the
  4063   "KRN",19,1 3996,1,2,0 )
  4064   AViVA Virt ual Patien t Record ( VPR) of pa tients tha t are expe cted to be
  4065   "KRN",19,1 3996,1,3,0 )
  4066   seen tomor row.
  4067   "KRN",19,1 3996,20)
  4068   D APPT^VPR PATS
  4069   "KRN",19,1 3996,200.9 )
  4070   y
  4071   "KRN",19,1 3996,"U")
  4072   RETURN LIS T OF TOMOR ROW'S PATI
  4073   "KRN",19,1 3997,-1)
  4074   0^2
  4075   "KRN",19,1 3997,0)
  4076   VPR PATIEN T DATA MON ITOR^VPR P atient Dat a Monitor^ ^A^^^^^^^^ VIRTUAL PA TIENT RECO RD^^1
  4077   "KRN",19,1 3997,1,0)
  4078   ^^4^4^3110 406^
  4079   "KRN",19,1 3997,1,1,0 )
  4080   This optio n manages  the VPR Pa tient Data  Monitor b ackground  job.  It 
  4081   "KRN",19,1 3997,1,2,0 )
  4082   first chec ks to see  if the job  is alread y running,  and will  prompt to
  4083   "KRN",19,1 3997,1,3,0 )
  4084   start it i f not.  It  may also  stop the j ob if runn ing, but t he AViVA
  4085   "KRN",19,1 3997,1,4,0 )
  4086   client may  not displ ay up-to-d ate data u ntil it is  started u p again.
  4087   "KRN",19,1 3997,20)
  4088   D EN^VPRHT TP
  4089   "KRN",19,1 3997,"U")
  4090   VPR PATIEN T DATA MON ITOR
  4091   "KRN",19,1 3998,-1)
  4092   0^4
  4093   "KRN",19,1 3998,0)
  4094   VPR SYNCHR ONIZATION  CONTEXT^Sy nchronize  the VPR^^B ^^^^^^^^
  4095   "KRN",19,1 3998,99.1)
  4096   63012,3326 5
  4097   "KRN",19,1 3998,"RPC" ,0)
  4098   ^19.05P^20 ^20
  4099   "KRN",19,1 3998,"RPC" ,2,0)
  4100   VPR DATA V ERSION
  4101   "KRN",19,1 3998,"RPC" ,4,0)
  4102   VPR SUBSCR IBE
  4103   "KRN",19,1 3998,"RPC" ,5,0)
  4104   VPR GET PA TIENT DATA  JSON
  4105   "KRN",19,1 3998,"RPC" ,7,0)
  4106   VPR GET OB JECT
  4107   "KRN",19,1 3998,"RPC" ,8,0)
  4108   VPR GET OP ERATIONAL  DATA
  4109   "KRN",19,1 3998,"RPC" ,10,0)
  4110   VPR PUT OB JECT
  4111   "KRN",19,1 3998,"RPC" ,17,0)
  4112   VPR GET CH ECKSUM
  4113   "KRN",19,1 3998,"RPC" ,19,0)
  4114   VPRDJFS AP I
  4115   "KRN",19,1 3998,"RPC" ,20,0)
  4116   VPRDJFS DE LSUB
  4117   "KRN",19,1 3998,"U")
  4118   SYNCHRONIZ E THE VPR
  4119   "KRN",19,1 3999,-1)
  4120   0^5
  4121   "KRN",19,1 3999,0)
  4122   VPR APPLIC ATION PROX Y^VPR Appl ication Pr oxy^^B^^^^ ^^^^VIRTUA L PATIENT  RECORD
  4123   "KRN",19,1 3999,1,0)
  4124   ^19.06^1^1 ^3110602^^ ^^
  4125   "KRN",19,1 3999,1,1,0 )
  4126   This optio n allows t he VPR con nector pro xy access  to the Vis tA system.
  4127   "KRN",19,1 3999,99.1)
  4128   62971,3386 5
  4129   "KRN",19,1 3999,"RPC" ,0)
  4130   ^19.05P^4^ 4
  4131   "KRN",19,1 3999,"RPC" ,2,0)
  4132   VPR GET PA TIENT DATA
  4133   "KRN",19,1 3999,"RPC" ,3,0)
  4134   VPR DATA V ERSION
  4135   "KRN",19,1 3999,"RPC" ,4,0)
  4136   VPR SUBSCR IBE
  4137   "KRN",19,1 3999,"U")
  4138   VPR APPLIC ATION PROX Y
  4139   "KRN",19,1 4005,-1)
  4140   0^3
  4141   "KRN",19,1 4005,0)
  4142   VPR UI CON TEXT^VPR U I CONTEXT  version 0. 7-S60^^B^^ ^^^^^^VIRT UAL PATIEN T RECORD
  4143   "KRN",19,1 4005,1,0)
  4144   ^^1^1^3110 630^
  4145   "KRN",19,1 4005,1,1,0 )
  4146   This optio n allows t he VPR UI  access to  the VistA  system.
  4147   "KRN",19,1 4005,99.1)
  4148   62990,2964 7
  4149   "KRN",19,1 4005,"RPC" ,0)
  4150   ^19.05P^41 ^41
  4151   "KRN",19,1 4005,"RPC" ,1,0)
  4152   VPRCORD RP C
  4153   "KRN",19,1 4005,"RPC" ,2,0)
  4154   VPRCPAT RP C
  4155   "KRN",19,1 4005,"RPC" ,3,0)
  4156   VPRFPTC CH KS
  4157   "KRN",19,1 4005,"RPC" ,4,0)
  4158   VPRFPTC LO G
  4159   "KRN",19,1 4005,"RPC" ,5,0)
  4160   VPR APPOIN TMENTS
  4161   "KRN",19,1 4005,"RPC" ,6,0)
  4162   VPR DATA V ERSION
  4163   "KRN",19,1 4005,"RPC" ,7,0)
  4164   VPR DELETE  ROSTER
  4165   "KRN",19,1 4005,"RPC" ,8,0)
  4166   VPR GET PA TIENT DATA
  4167   "KRN",19,1 4005,"RPC" ,9,0)
  4168   VPR GET SO URCE
  4169   "KRN",19,1 4005,"RPC" ,10,0)
  4170   VPR INPATI ENTS
  4171   "KRN",19,1 4005,"RPC" ,11,0)
  4172   VPR PREVIE W ROSTER
  4173   "KRN",19,1 4005,"RPC" ,12,0)
  4174   VPR ROSTER  PATIENTS
  4175   "KRN",19,1 4005,"RPC" ,13,0)
  4176   VPR ROSTER S
  4177   "KRN",19,1 4005,"RPC" ,14,0)
  4178   VPR SUBSCR IBE
  4179   "KRN",19,1 4005,"RPC" ,15,0)
  4180   VPR UPDATE  ROSTER
  4181   "KRN",19,1 4005,"RPC" ,16,0)
  4182   VPRCRPC RP C
  4183   "KRN",19,1 4005,"RPC" ,19,0)
  4184   XHD GET PA RAMETER DE F LIST
  4185   "KRN",19,1 4005,"RPC" ,20,0)
  4186   VPR PUT PA TIENT DATA
  4187   "KRN",19,1 4005,"RPC" ,21,0)
  4188   VPR PUT OB JECT
  4189   "KRN",19,1 4005,"RPC" ,22,0)
  4190   VPR DELETE  OBJECT
  4191   "KRN",19,1 4005,"RPC" ,23,0)
  4192   VPR GET OB JECT
  4193   "KRN",19,1 4005,"RPC" ,24,0)
  4194   VPR GET RO STER LIST
  4195   "KRN",19,1 4005,"RPC" ,25,0)
  4196   VPRCPRS RP C
  4197   "KRN",19,1 4005,"RPC" ,26,0)
  4198   ORQPT WARD S
  4199   "KRN",19,1 4005,"RPC" ,27,0)
  4200   ORQPT WARD  PATIENTS
  4201   "KRN",19,1 4005,"RPC" ,28,0)
  4202   ORQPT SPEC IALTIES
  4203   "KRN",19,1 4005,"RPC" ,29,0)
  4204   ORQPT SPEC IALTY PATI ENTS
  4205   "KRN",19,1 4005,"RPC" ,30,0)
  4206   ORWU CLINL OC
  4207   "KRN",19,1 4005,"RPC" ,31,0)
  4208   ORQPT CLIN IC PATIENT S
  4209   "KRN",19,1 4005,"RPC" ,32,0)
  4210   ORWU NEWPE RS
  4211   "KRN",19,1 4005,"RPC" ,33,0)
  4212   ORQPT PROV IDER PATIE NTS
  4213   "KRN",19,1 4005,"RPC" ,34,0)
  4214   ORWRP COLU MN HEADERS
  4215   "KRN",19,1 4005,"RPC" ,35,0)
  4216   ORWLR CUMU LATIVE REP ORT
  4217   "KRN",19,1 4005,"RPC" ,36,0)
  4218   ORWLRR INT ERIM
  4219   "KRN",19,1 4005,"RPC" ,37,0)
  4220   ORWRP REPO RT TEXT
  4221   "KRN",19,1 4005,"RPC" ,38,0)
  4222   ORWRP3 EXP AND COLUMN S
  4223   "KRN",19,1 4005,"RPC" ,39,0)
  4224   VPR PUT DE MOGRAPHICS
  4225   "KRN",19,1 4005,"RPC" ,40,0)
  4226   VPRCRPC RP CCHAIN
  4227   "KRN",19,1 4005,"RPC" ,41,0)
  4228   ORQPT DEFA ULT PATIEN T LIST
  4229   "KRN",19,1 4005,"U")
  4230   VPR UI CON TEXT VERSI ON 0.7-S60
  4231   "KRN",19,1 4101,-1)
  4232   0^6
  4233   "KRN",19,1 4101,0)
  4234   VPR XU EVE NTS^New Pe rson event s for VPR^ ^A^^^^^^^^ VIRTUAL PA TIENT RECO RD^^1
  4235   "KRN",19,1 4101,1,0)
  4236   ^^1^1^3130 116^
  4237   "KRN",19,1 4101,1,1,0 )
  4238   This proto col will t rack New P erson upda tes for VP R.
  4239   "KRN",19,1 4101,20)
  4240   D XU^VPREV NT(XUIEN," ")
  4241   "KRN",19,1 4101,"U")
  4242   NEW PERSON  EVENTS FO R VPR
  4243   "KRN",19,1 4233,-1)
  4244   0^10
  4245   "KRN",19,1 4233,0)
  4246   VPRM ADD H MP USER^Ad d Health M anagement  Platform U ser^^A^^^^ ^^^^VIRTUA L PATIENT  RECORD^^1
  4247   "KRN",19,1 4233,1,0)
  4248   ^^4^4^3140 326^
  4249   "KRN",19,1 4233,1,1,0 )
  4250   This optio n allows a  user to b e given ac cess to us e the Heal th Managem ent
  4251   "KRN",19,1 4233,1,2,0 )
  4252   Platform.   The selec ted user w ill be giv en the VPR  UI CONTEX T option.
  4253   "KRN",19,1 4233,1,3,0 )
  4254   Additional ly, their  default pa tient list  my be set  up for au tomatic
  4255   "KRN",19,1 4233,1,4,0 )
  4256   synchroniz ation with  the Healt h Manageme nt Platfor m (HMP).
  4257   "KRN",19,1 4233,20)
  4258   D OPTASGN^ VPRCAC
  4259   "KRN",19,1 4233,"U")
  4260   ADD HEALTH  MANAGEMEN T PLATFORM
  4261   "KRN",19,1 4234,-1)
  4262   0^12
  4263   "KRN",19,1 4234,0)
  4264   VPRM EXTRA CT MONITOR ^Monitor H MP Server  Synchroniz ation^^A^^ ^^^^^^VIRT UAL PATIEN T RECORD^^ 1
  4265   "KRN",19,1 4234,1,0)
  4266   ^^2^2^3140 402^
  4267   "KRN",19,1 4234,1,1,0 )
  4268   This optio n allow on e to monit or the pol ls from an  HMP serve r and any 
  4269   "KRN",19,1 4234,1,2,0 )
  4270   currently  executing  VPR extrac ts.
  4271   "KRN",19,1 4234,20)
  4272   D EN^VPRDJ FSM
  4273   "KRN",19,1 4234,"U")
  4274   MONITOR HM P SERVER S YNCHRONIZA
  4275   "KRN",19,1 4235,-1)
  4276   0^11
  4277   "KRN",19,1 4235,0)
  4278   VPRM EMERG ENCY STOP^ Emergency  Stop VPR F reshness U pdates^^A^ ^^^^^^^VIR TUAL PATIE NT RECORD^ ^1
  4279   "KRN",19,1 4235,1,0)
  4280   ^^5^5^3140 403^
  4281   "KRN",19,1 4235,1,1,0 )
  4282   This optio n should b e used wit h caution.   It will  stop the f reshness 
  4283   "KRN",19,1 4235,1,2,0 )
  4284   events for  the Virtu al Patient  Record (V PR) from b eing calle d.  Once t he 
  4285   "KRN",19,1 4235,1,3,0 )
  4286   freshness  events are  stopped,  patient da ta must be  re-synchr onized wit h
  4287   "KRN",19,1 4235,1,4,0 )
  4288   the VPR to  ensure co mpleteness .  Only st op freshne ss updates  if there  is a
  4289   "KRN",19,1 4235,1,5,0 )
  4290   problem wi th system  operation.
  4291   "KRN",19,1 4235,20)
  4292   D EMERSTOP ^VPRDJFSM
  4293   "KRN",19,1 4235,"U")
  4294   EMERGENCY  STOP VPR F RESHNESS U
  4295   "KRN",19,1 4236,-1)
  4296   0^13
  4297   "KRN",19,1 4236,0)
  4298   VPRM ADD H MP PATIENT ^Manually  Add Patien t to VPR^^ A^^^^^^^^V IRTUAL PAT IENT RECOR D^^1
  4299   "KRN",19,1 4236,1,0)
  4300   ^^2^2^3140 404^
  4301   "KRN",19,1 4236,1,1,0 )
  4302   Use this p atient to  manually a dd a patie nt for syn chronizati on with th
  4303   "KRN",19,1 4236,1,2,0 )
  4304   Virtual Pa tient Reco rd (VPR).
  4305   "KRN",19,1 4236,20)
  4306   D ADDPT^VP RDJFSM
  4307   "KRN",19,1 4236,"U")
  4308   MANUALLY A DD PATIENT  TO VPR
  4309   "KRN",19,1 4237,-1)
  4310   0^14
  4311   "KRN",19,1 4237,0)
  4312   VPRMGR^HMP  Technical  Managemen t^^M^^^^^^ ^^VIRTUAL  PATIENT RE CORD
  4313   "KRN",19,1 4237,1,0)
  4314   ^^1^1^3140 404^
  4315   "KRN",19,1 4237,1,1,0 )
  4316   This menu  contains v arious opt ions to he lp with th e manageme nt of HMP.
  4317   "KRN",19,1 4237,10,0)
  4318   ^19.01IP^3 ^3
  4319   "KRN",19,1 4237,10,1, 0)
  4320   14233
  4321   "KRN",19,1 4237,10,1, "^")
  4322   VPRM ADD H MP USER
  4323   "KRN",19,1 4237,10,2, 0)
  4324   14236
  4325   "KRN",19,1 4237,10,2, "^")
  4326   VPRM ADD H MP PATIENT
  4327   "KRN",19,1 4237,10,3, 0)
  4328   14234
  4329   "KRN",19,1 4237,10,3, "^")
  4330   VPRM EXTRA CT MONITOR
  4331   "KRN",19,1 4237,99)
  4332   63349,2444
  4333   "KRN",19,1 4237,"U")
  4334   HMP TECHNI CAL MANAGE MENT
  4335   "KRN",19,1 4245,-1)
  4336   0^15
  4337   "KRN",19,1 4245,0)
  4338   VPRM RESTA RT FRESHNE SS^Resume  Freshness  Updates th at have be en stopped ^^A^^^^^^^ ^VIRTUAL P ATIENT REC ORD^^1
  4339   "KRN",19,1 4245,1,0)
  4340   ^^4^4^3140 604^
  4341   "KRN",19,1 4245,1,1,0 )
  4342   This optio n will rem ove the fl ags that c ause fresh ness updat es to be 
  4343   "KRN",19,1 4245,1,2,0 )
  4344   stopped.   It will li kely be ne cessary to  re-synchr onized pat ients afte
  4345   "KRN",19,1 4245,1,3,0 )
  4346   freshness  has been s topped, si nce update s will be  missing fr om the tim
  4347   "KRN",19,1 4245,1,4,0 )
  4348   that fresh ness updat es were no t being re cieved.
  4349   "KRN",19,1 4245,20)
  4350   D RSTRTFR^ VPRDJFSM
  4351   "KRN",19,1 4245,"U")
  4352   RESUME FRE SHNESS UPD ATES THAT 
  4353   "KRN",19.1 ,646,-1)
  4354   0^1
  4355   "KRN",19.1 ,646,0)
  4356   VPR EXPERI MENTAL
  4357   "KRN",19.1 ,685,-1)
  4358   0^2
  4359   "KRN",19.1 ,685,0)
  4360   VPR ADMIN
  4361   "KRN",101, 1240,-1)
  4362   2^8
  4363   "KRN",101, 1240,0)
  4364   DGPM MOVEM ENT EVENTS ^MOVEMENT  EVENTS v 5 .0^^X^1085 ^^^^^^^114
  4365   "KRN",101, 1240,10,0)
  4366   ^101.01PA^ 38^38
  4367   "KRN",101, 1240,10,38 ,0)
  4368   5869^^^
  4369   "KRN",101, 1240,10,38 ,"^")
  4370   VPR INPT E VENTS
  4371   "KRN",101, 1302,-1)
  4372   2^13
  4373   "KRN",101, 1302,0)
  4374   SDAM APPOI NTMENT EVE NTS^Appoin tment Even t Driver^^ X^1085^^^^ ^^^16
  4375   "KRN",101, 1302,10,0)
  4376   ^101.01PA^ 20^20
  4377   "KRN",101, 1302,10,20 ,0)
  4378   5870^^^
  4379   "KRN",101, 1302,10,20 ,"^")
  4380   VPR APPT E VENTS
  4381   "KRN",101, 2690,-1)
  4382   2^12
  4383   "KRN",101, 2690,0)
  4384   RA EVSEND  OR^Radiolo gy event s ent to OE/ RR^^X^1085 ^^^^^^^31
  4385   "KRN",101, 2690,10,0)
  4386   ^101.01PA^ 4^4
  4387   "KRN",101, 2690,10,4, 0)
  4388   5872^^^
  4389   "KRN",101, 2690,10,4, "^")
  4390   VPR XQOR E VENTS
  4391   "KRN",101, 2700,-1)
  4392   2^11
  4393   "KRN",101, 2700,0)
  4394   PXK VISIT  DATA EVENT ^VISIT REL ATED DATA^ ^X^1085^^^ ^^^^
  4395   "KRN",101, 2700,10,0)
  4396   ^101.01PA^ 6^6
  4397   "KRN",101, 2700,10,6, 0)
  4398   5871^^^
  4399   "KRN",101, 2700,10,6, "^")
  4400   VPR PCE EV ENTS
  4401   "KRN",101, 2894,-1)
  4402   2^16
  4403   "KRN",101, 2894,0)
  4404   GMRA SIGN- OFF ON DAT A^Sign-off  on Reacti on Data^^X ^1085^^^^^ ^^247
  4405   "KRN",101, 2894,10,0)
  4406   ^101.01PA^ 2^2
  4407   "KRN",101, 2894,10,2, 0)
  4408   5873^^^
  4409   "KRN",101, 2894,10,2, "^")
  4410   VPR GMRA E VENTS
  4411   "KRN",101, 2896,-1)
  4412   2^15
  4413   "KRN",101, 2896,0)
  4414   GMRA ENTER ED IN ERRO R^Reaction  Data Ente red in Err or^^X^1085 ^^^^^^^247
  4415   "KRN",101, 2896,10,0)
  4416   ^101.01PA^ 2^2
  4417   "KRN",101, 2896,10,2, 0)
  4418   5873^^^
  4419   "KRN",101, 2896,10,2, "^")
  4420   VPR GMRA E VENTS
  4421   "KRN",101, 3336,-1)
  4422   2^9
  4423   "KRN",101, 3336,0)
  4424   LR7O CH EV SEND OR^LA B => OE/RR  ORDER MES SAGE EVENT ^^X^1085^^ ^^^^^
  4425   "KRN",101, 3336,10,0)
  4426   ^101.01PA^ 4^4
  4427   "KRN",101, 3336,10,4, 0)
  4428   5872^^^
  4429   "KRN",101, 3336,10,4, "^")
  4430   VPR XQOR E VENTS
  4431   "KRN",101, 3373,-1)
  4432   2^10
  4433   "KRN",101, 3373,0)
  4434   PS EVSEND  OR^Send Ph armacy ord ers to CPR S.^^X^1085 ^^^^^^^18
  4435   "KRN",101, 3373,10,0)
  4436   ^101.01PA^ 6^6
  4437   "KRN",101, 3373,10,6, 0)
  4438   5872^^^
  4439   "KRN",101, 3373,10,6, "^")
  4440   VPR XQOR E VENTS
  4441   "KRN",101, 3392,-1)
  4442   2^17
  4443   "KRN",101, 3392,0)
  4444   GMRC EVSEN D OR^Consu lts event  sent to OE /RR^^X^108 5^^^^^^^29 4
  4445   "KRN",101, 3392,10,0)
  4446   ^101.01PA^ 6^6
  4447   "KRN",101, 3392,10,6, 0)
  4448   5872^^^
  4449   "KRN",101, 3392,10,6, "^")
  4450   VPR XQOR E VENTS
  4451   "KRN",101, 3411,-1)
  4452   2^33
  4453   "KRN",101, 3411,0)
  4454   FH EVSEND  OR^FH -->  OR event m essages^^X ^1085^^^^^ ^^
  4455   "KRN",101, 3411,10,0)
  4456   ^101.01PA^ 4^4
  4457   "KRN",101, 3411,10,4, 0)
  4458   5872^^^
  4459   "KRN",101, 3411,10,4, "^")
  4460   VPR XQOR E VENTS
  4461   "KRN",101, 3417,-1)
  4462   2^36
  4463   "KRN",101, 3417,0)
  4464   VAFC ADT-A 04 SERVER^ This proto col fires  off of the  PIMS Regi stration o ption^^E^1 085^^^^^^^ 114
  4465   "KRN",101, 3417,775,0 )
  4466   ^101.0775P A^6^6
  4467   "KRN",101, 3417,775,6 ,0)
  4468   6054
  4469   "KRN",101, 3417,775,6 ,"^")
  4470   VPR ADT-A0 4 CLIENT
  4471   "KRN",101, 3418,-1)
  4472   2^40
  4473   "KRN",101, 3418,0)
  4474   VAFC ADT-A 08 SERVER^ Registrati on's ADT-A 08 Server  Protocol^^ E^1085^^^^ ^^^114
  4475   "KRN",101, 3418,775,0 )
  4476   ^101.0775P A^6^6
  4477   "KRN",101, 3418,775,6 ,0)
  4478   6065
  4479   "KRN",101, 3418,775,6 ,"^")
  4480   VPR ADT-A0 8 CLIENT
  4481   "KRN",101, 3529,-1)
  4482   2^26
  4483   "KRN",101, 3529,0)
  4484   OR EVSEND  RA^OE/RR = > RAD/NM M ESSAGE EVE NT^^X^1085 ^^^^^^^
  4485   "KRN",101, 3529,10,0)
  4486   ^101.01PA^ 4^4
  4487   "KRN",101, 3529,10,4, 0)
  4488   5874^^^
  4489   "KRN",101, 3529,10,4, "^")
  4490   VPR NA EVE NTS
  4491   "KRN",101, 3530,-1)
  4492   2^23
  4493   "KRN",101, 3530,0)
  4494   OR EVSEND  LRCH^OE/RR  => LAB ME SSAGE EVEN T^^X^1085^ ^^^^^^
  4495   "KRN",101, 3530,10,0)
  4496   ^101.01PA^ 4^4
  4497   "KRN",101, 3530,10,4, 0)
  4498   5874^^^
  4499   "KRN",101, 3530,10,4, "^")
  4500   VPR NA EVE NTS
  4501   "KRN",101, 3535,-1)
  4502   2^31
  4503   "KRN",101, 3535,0)
  4504   OR EVSEND  FH^OE/RR = > DIET MES SAGE EVENT ^^X^1085^^ ^^^^^
  4505   "KRN",101, 3535,10,0)
  4506   ^101.01PA^ 4^4
  4507   "KRN",101, 3535,10,4, 0)
  4508   5874^^^
  4509   "KRN",101, 3535,10,4, "^")
  4510   VPR NA EVE NTS
  4511   "KRN",101, 3536,-1)
  4512   2^24
  4513   "KRN",101, 3536,0)
  4514   OR EVSEND  ORG^OE/RR  => GENERIC  MESSAGE E VENT^^X^10 85^^^^^^^
  4515   "KRN",101, 3536,10,0)
  4516   ^101.01PA^ 4^4
  4517   "KRN",101, 3536,10,4, 0)
  4518   5872^^^
  4519   "KRN",101, 3536,10,4, "^")
  4520   VPR XQOR E VENTS
  4521   "KRN",101, 3537,-1)
  4522   2^25
  4523   "KRN",101, 3537,0)
  4524   OR EVSEND  PS^OE/RR = > PHARMACY  MESSAGE E VENT^^X^10 85^^^^^^^
  4525   "KRN",101, 3537,10,0)
  4526   ^101.01PA^ 4^4
  4527   "KRN",101, 3537,10,4, 0)
  4528   5874^^^
  4529   "KRN",101, 3537,10,4, "^")
  4530   VPR NA EVE NTS
  4531   "KRN",101, 3539,-1)
  4532   2^20
  4533   "KRN",101, 3539,0)
  4534   OR EVSEND  GMRC^OE/RR  => CONSUL TS MESSAGE  EVENT^^X^ 1085^^^^^^ ^
  4535   "KRN",101, 3539,10,0)
  4536   ^101.01PA^ 6^6
  4537   "KRN",101, 3539,10,6, 0)
  4538   5874^^^
  4539   "KRN",101, 3539,10,6, "^")
  4540   VPR NA EVE NTS
  4541   "KRN",101, 4717,-1)
  4542   2^7
  4543   "KRN",101, 4717,0)
  4544   DG FIELD M ONITOR^DG  Field Moni tor^^X^108 5^^^^^^^11 4
  4545   "KRN",101, 4717,10,0)
  4546   ^101.01PA^ 5^5
  4547   "KRN",101, 4717,10,5, 0)
  4548   5868^^^
  4549   "KRN",101, 4717,10,5, "^")
  4550   VPR DG UPD ATES
  4551   "KRN",101, 5868,-1)
  4552   0^2
  4553   "KRN",101, 5868,0)
  4554   VPR DG UPD ATES^DG up dates for  VPR^^A^^^^ ^^^^
  4555   "KRN",101, 5868,1,0)
  4556   ^101.06^1^ 1^3101129^ ^^^
  4557   "KRN",101, 5868,1,1,0 )
  4558   This proto col will t rack Patie nt file ch anges for  VPR.
  4559   "KRN",101, 5868,20)
  4560   D DG^VPREV NT
  4561   "KRN",101, 5868,99)
  4562   63349,2443
  4563   "KRN",101, 5869,-1)
  4564   0^3
  4565   "KRN",101, 5869,0)
  4566   VPR INPT E VENTS^Inpa tient Move ment event s for VPR^ ^A^^^^^^^^
  4567   "KRN",101, 5869,1,0)
  4568   ^101.06^1^ 1^3101202^ ^^^
  4569   "KRN",101, 5869,1,1,0 )
  4570   This proto col will t rack patie nt admissi ons and di scharges f or VPR.
  4571   "KRN",101, 5869,20)
  4572   D DGPM^VPR EVNT
  4573   "KRN",101, 5869,99)
  4574   63349,2443
  4575   "KRN",101, 5870,-1)
  4576   0^1
  4577   "KRN",101, 5870,0)
  4578   VPR APPT E VENTS^Appo intment ev ents for V PR^^A^^^^^ ^^^
  4579   "KRN",101, 5870,1,0)
  4580   ^101.06^1^ 1^3101129^ ^^^
  4581   "KRN",101, 5870,1,1,0 )
  4582   This proto col will t rack appoi ntments fo r VPR.
  4583   "KRN",101, 5870,20)
  4584   D SDAM^VPR EVNT
  4585   "KRN",101, 5870,99)
  4586   63349,2443
  4587   "KRN",101, 5871,-1)
  4588   0^4
  4589   "KRN",101, 5871,0)
  4590   VPR PCE EV ENTS^PCE e vents for  VPR^^A^^^^ ^^^^
  4591   "KRN",101, 5871,1,0)
  4592   ^101.06^1^ 1^3101129^ ^^
  4593   "KRN",101, 5871,1,1,0 )
  4594   This proto col will t rack PCE v isit data  for VPR.
  4595   "KRN",101, 5871,20)
  4596   D PCE^VPRE VNT
  4597   "KRN",101, 5871,99)
  4598   63349,2443
  4599   "KRN",101, 5872,-1)
  4600   0^5
  4601   "KRN",101, 5872,0)
  4602   VPR XQOR E VENTS^XQOR  HL7 event s for VPR^ ^A^^^^^^^^
  4603   "KRN",101, 5872,1,0)
  4604   ^101.06^3^ 3^3101129^ ^
  4605   "KRN",101, 5872,1,1,0 )
  4606   This proto col monito rs order e vents for  VPR.  It i s placed o n the 
  4607   "KRN",101, 5872,1,2,0 )
  4608   * EVSEND O R protocol s to check  for updat es being s ent from a ncillary
  4609   "KRN",101, 5872,1,3,0 )
  4610   packages t o Order En try; it mo nitors whe n orders a re complet ed.
  4611   "KRN",101, 5872,20)
  4612   D XQOR^VPR EVNT(.XQOR MSG)
  4613   "KRN",101, 5872,99)
  4614   63349,2443
  4615   "KRN",101, 5873,-1)
  4616   0^14
  4617   "KRN",101, 5873,0)
  4618   VPR GMRA E VENTS^Alle rgy Events  for VPR^^ A^^^^^^^^
  4619   "KRN",101, 5873,1,0)
  4620   ^101.06^1^ 1^3120822^ ^
  4621   "KRN",101, 5873,1,1,0 )
  4622   This proto col will t rack Aller gy data up dates for  VPR.
  4623   "KRN",101, 5873,20)
  4624   D GMRA^VPR EVNT("")
  4625   "KRN",101, 5873,99)
  4626   63349,2443
  4627   "KRN",101, 5874,-1)
  4628   0^29
  4629   "KRN",101, 5874,0)
  4630   VPR NA EVE NTS^XQOR H L7 events  for VPR^^A ^^^^^^^^
  4631   "KRN",101, 5874,1,0)
  4632   ^101.06^3^ 3^3110818^ ^^
  4633   "KRN",101, 5874,1,1,0 )
  4634   This proto col monito rs order e vents for  VPR.  It i s placed o n the 
  4635   "KRN",101, 5874,1,2,0 )
  4636   OR EVSEND  * protocol s to check  for order  numbers a ssigned to  new order s
  4637   "KRN",101, 5874,1,3,0 )
  4638   placed fro m the anci llary pack ages.
  4639   "KRN",101, 5874,20)
  4640   D NA^VPREV NT(.XQORMS G)
  4641   "KRN",101, 5874,99)
  4642   63349,2443
  4643   "KRN",101, 5875,-1)
  4644   2^27
  4645   "KRN",101, 5875,0)
  4646   GMPL EVENT ^Problem L ist Update  Event^^X^ 1085^^^^^^ ^402
  4647   "KRN",101, 5875,10,0)
  4648   ^101.01PA^ 1^1
  4649   "KRN",101, 5875,10,1, 0)
  4650   5876^^1^
  4651   "KRN",101, 5875,10,1, "^")
  4652   VPR GMPL E VENT
  4653   "KRN",101, 5876,-1)
  4654   0^28
  4655   "KRN",101, 5876,0)
  4656   VPR GMPL E VENT^Probl em List ev ents for V PR^^A^^^^^ ^^^
  4657   "KRN",101, 5876,1,0)
  4658   ^101.06^1^ 1^3110823^ ^^^
  4659   "KRN",101, 5876,1,1,0 )
  4660   This proto col will t rack new a nd updated  problems  for VPR.
  4661   "KRN",101, 5876,20)
  4662   D GMPL^VPR EVNT(DFN,G MPIFN)
  4663   "KRN",101, 5876,99)
  4664   63349,2443
  4665   "KRN",101, 5982,-1)
  4666   2^30
  4667   "KRN",101, 5982,0)
  4668   MDC OBSERV ATION UPDA TE^Observa tion updat e notifica tion^^X^10 85^^^^^^^5 57
  4669   "KRN",101, 5982,10,0)
  4670   ^101.01PA^ 5^1
  4671   "KRN",101, 5982,10,5, 0)
  4672   5983^^^
  4673   "KRN",101, 5982,10,5, "^")
  4674   VPR MDC EV ENT
  4675   "KRN",101, 5982,775,0 )
  4676   ^101.0775P A^^
  4677   "KRN",101, 5983,-1)
  4678   0^32
  4679   "KRN",101, 5983,0)
  4680   VPR MDC EV ENT^CLiO e vents for  VPR^^A^^^^ ^^^^
  4681   "KRN",101, 5983,1,0)
  4682   ^101.06^1^ 1^3120830^ ^^^
  4683   "KRN",101, 5983,1,1,0 )
  4684   This proto col will t rack new a nd updated  observati ons for VP R.
  4685   "KRN",101, 5983,20)
  4686   D MDC^VPRE VNT(.MDCOB S)
  4687   "KRN",101, 5983,99)
  4688   63349,2443
  4689   "KRN",101, 6053,-1)
  4690   2^34
  4691   "KRN",101, 6053,0)
  4692   OR EVSEND  VPR^OE/RR  => VPR MES SAGE EVENT ^^X^1085^^ ^^^^^
  4693   "KRN",101, 6053,10,0)
  4694   ^101.01PA^ 7^1
  4695   "KRN",101, 6053,10,7, 0)
  4696   5872^^^
  4697   "KRN",101, 6053,10,7, "^")
  4698   VPR XQOR E VENTS
  4699   "KRN",101, 6054,-1)
  4700   0^35
  4701   "KRN",101, 6054,0)
  4702   VPR ADT-A0 4 CLIENT^V PR HL7 ADT -A04 Clien t^^S^^^^^^ ^^VIRTUAL  PATIENT RE CORD
  4703   "KRN",101, 6054,1,0)
  4704   ^^10^10^31 40326^
  4705   "KRN",101, 6054,1,1,0 )
  4706   This clien t protocol  is used t o process  HL7 ADT/A0 4 messages  published  by 
  4707   "KRN",101, 6054,1,2,0 )
  4708   the VAFC A DT-A04 SER VER protoc ol.
  4709   "KRN",101, 6054,1,3,0 )
  4710    
  4711   "KRN",101, 6054,1,4,0 )
  4712   The client  causes a  VPR 'fresh ness' even t for each  new patie nt 
  4713   "KRN",101, 6054,1,5,0 )
  4714   registrati on that oc curs. This  is especi ally impor tant for n ew patient s, 
  4715   "KRN",101, 6054,1,6,0 )
  4716   as it is t he only MA S event me chanism av ailable th at can be  used to 
  4717   "KRN",101, 6054,1,7,0 )
  4718   discover n ew patient  entries.
  4719   "KRN",101, 6054,1,8,0 )
  4720    
  4721   "KRN",101, 6054,1,9,0 )
  4722   Note: The  ROUTING LO GIC does n ot send an y HL7 mess ages. As m entioned 
  4723   "KRN",101, 6054,1,10, 0)
  4724   above, It  adds a HMP  (Health M anagement  Platform)  'freshness ' event.
  4725   "KRN",101, 6054,99)
  4726   63349,2443
  4727   "KRN",101, 6054,770)
  4728   ^VPR HL7^^ ^^^^^^^ADT
  4729   "KRN",101, 6054,774)
  4730   D ADT^VPRE HL7
  4731   "KRN",101, 6063,-1)
  4732   2^38
  4733   "KRN",101, 6063,0)
  4734   PSB EVSEND  VPR^MEDIC ATION ADMI NISTRATION  EVENTS^^X ^1085^^^^^ ^^
  4735   "KRN",101, 6063,10,0)
  4736   ^101.01PA^ 2^1
  4737   "KRN",101, 6063,10,2, 0)
  4738   6064^^^
  4739   "KRN",101, 6063,10,2, "^")
  4740   VPR PSB EV ENTS
  4741   "KRN",101, 6064,-1)
  4742   0^37
  4743   "KRN",101, 6064,0)
  4744   VPR PSB EV ENTS^BCMA  events for  VPR^^A^^^ ^^^^^
  4745   "KRN",101, 6064,1,0)
  4746   ^101.06^1^ 1^3140415^ ^^^
  4747   "KRN",101, 6064,1,1,0 )
  4748   This proto col will t rack medic ation admi nistration s for VPR.
  4749   "KRN",101, 6064,20)
  4750   D PSB^VPRE VNT
  4751   "KRN",101, 6064,99)
  4752   63349,2443
  4753   "KRN",101, 6065,-1)
  4754   0^39
  4755   "KRN",101, 6065,0)
  4756   VPR ADT-A0 8 CLIENT^V PR HL7 ADT -A08 Clien t^^S^^^^^^ ^^VIRTUAL  PATIENT RE CORD
  4757   "KRN",101, 6065,1,0)
  4758   ^^10^10^31 40604^
  4759   "KRN",101, 6065,1,1,0 )
  4760   This clien t protocol  is used t o process  HL7 ADT/A0 8 messages  published  by 
  4761   "KRN",101, 6065,1,2,0 )
  4762   the VAFC A DT-A08 SER VER protoc ol.
  4763   "KRN",101, 6065,1,3,0 )
  4764    
  4765   "KRN",101, 6065,1,4,0 )
  4766   The client  filters A 08 events.  It adds t o the VPR  'freshness ' queue on ly
  4767   "KRN",101, 6065,1,5,0 )
  4768   if the A08  was the r esult of t he patient 's sensiti vity being  modified  via
  4769   "KRN",101, 6065,1,6,0 )
  4770   the DG SEC URITY EDIT /EDIT opti on. All ot her A08 ev ents are i gnored and
  4771   "KRN",101, 6065,1,7,0 )
  4772   should not  add to th e 'freshne ss' queue.
  4773   "KRN",101, 6065,1,8,0 )
  4774    
  4775   "KRN",101, 6065,1,9,0 )
  4776   Note: The  ROUTING LO GIC does n ot send an y HL7 mess ages. As m entioned 
  4777   "KRN",101, 6065,1,10, 0)
  4778   above, It  adds a HMP  (Health M anagement  Platform)  'freshness ' event.
  4779   "KRN",101, 6065,4)
  4780   ^^^
  4781   "KRN",101, 6065,99)
  4782   63349,2443
  4783   "KRN",101, 6065,770)
  4784   ^VPR HL7^^ ^^^^^^^ADT
  4785   "KRN",101, 6065,774)
  4786   D ADT^VPRE HL7
  4787   "KRN",771, 238,-1)
  4788   0^1
  4789   "KRN",771, 238,0)
  4790   VPR HL7^a^ ^^^^USA
  4791   "KRN",8989 .5,13424,0 )
  4792   571;DIC(9. 4,^VPR TAS K WAIT TIM E^1
  4793   "KRN",8989 .5,13424,1 )
  4794   99
  4795   "KRN",8989 .51,651,-1 )
  4796   0^2
  4797   "KRN",8989 .51,651,0)
  4798   VPR TASK W AIT TIME^H ang time u ntil next  cycle^^^#S ECONDS
  4799   "KRN",8989 .51,651,1)
  4800   N^1:9999^E nter the n umber of s econds to  wait befor e the VPR  Data Monit or re-queu es.
  4801   "KRN",8989 .51,651,20 ,0)
  4802   ^^2^2^3110 317^
  4803   "KRN",8989 .51,651,20 ,1,0)
  4804   This is th e number o f seconds  that the s ystem will  wait befo re re-queu ing
  4805   "KRN",8989 .51,651,20 ,2,0)
  4806   the VPR Da ta Monitor  backgroun d job.
  4807   "KRN",8989 .51,651,30 ,0)
  4808   ^8989.513I ^2^2
  4809   "KRN",8989 .51,651,30 ,1,0)
  4810   1^9.4
  4811   "KRN",8989 .51,651,30 ,2,0)
  4812   2^4.2
  4813   "KRN",8989 .51,652,-1 )
  4814   0^1
  4815   "KRN",8989 .51,652,0)
  4816   VPR LOCATI ONS^VPR Lo cations^1^ Clinic^Syn cronized
  4817   "KRN",8989 .51,652,1)
  4818   Y
  4819   "KRN",8989 .51,652,6)
  4820   P^44^Enter  clinic to  synch wit h VPR
  4821   "KRN",8989 .51,652,30 ,0)
  4822   ^8989.513I ^1^1
  4823   "KRN",8989 .51,652,30 ,1,0)
  4824   5^4
  4825   "KRN",8989 .51,656,-1 )
  4826   0^3
  4827   "KRN",8989 .51,656,0)
  4828   VPR PARAME TERS^VPR S YSTEM PARA METERS^1^S ystem Para meters^Sys tem Parame ters Name
  4829   "KRN",8989 .51,656,1)
  4830   W
  4831   "KRN",8989 .51,656,6)
  4832   F
  4833   "KRN",8989 .51,656,20 ,0)
  4834   ^8989.512^ 2^2^312012 5^^^
  4835   "KRN",8989 .51,656,20 ,1,0)
  4836   This param eter store s a list o f paramete rs used by  the VPR m iddle teir  
  4837   "KRN",8989 .51,656,20 ,2,0)
  4838   and the VP R UI.
  4839   "KRN",8989 .51,656,30 ,0)
  4840   ^8989.513I ^2^2
  4841   "KRN",8989 .51,656,30 ,1,0)
  4842   6^4.2
  4843   "KRN",8989 .51,656,30 ,2,0)
  4844   1^200
  4845   "KRN",8989 .51,740,-1 )
  4846   0^4
  4847   "KRN",8989 .51,740,0)
  4848   VPR CPRS P ATH^CPRS L ocation^0
  4849   "KRN",8989 .51,740,1)
  4850   F
  4851   "KRN",8989 .51,740,6)
  4852   F
  4853   "KRN",8989 .51,740,30 ,0)
  4854   ^8989.513I ^2^2
  4855   "KRN",8989 .51,740,30 ,1,0)
  4856   4^4.2
  4857   "KRN",8989 .51,740,30 ,2,0)
  4858   1^200
  4859   "KRN",8994 ,815,-1)
  4860   0^22
  4861   "KRN",8994 ,815,0)
  4862   VPR GET RE FERENCE DA TA^GET^VPR EF^4^S^^^0 ^1^^1
  4863   "KRN",8994 ,815,1,0)
  4864   ^^2^2^3131 105
  4865   "KRN",8994 ,815,1,1,0 )
  4866   This RPC r etrieves t he request ed data fr om VistA,  and return s it in
  4867   "KRN",8994 ,815,1,2,0 )
  4868   ^TMP("VPR" ,$J,n) as  JSON.
  4869   "KRN",8994 ,815,2,0)
  4870   ^8994.02A^ 1^1
  4871   "KRN",8994 ,815,2,1,0 )
  4872   FILTER^2^^ 0^1
  4873   "KRN",8994 ,815,2,1,1 ,0)
  4874   ^^1^1^3131 105
  4875   "KRN",8994 ,815,2,1,1 ,1,0)
  4876   List of na me-value p airs defin ing the se arch.
  4877   "KRN",8994 ,815,2,"B" ,"FILTER", 1)
  4878  
  4879   "KRN",8994 ,815,2,"PA RAMSEQ",1, 1)
  4880  
  4881   "KRN",8994 ,815,3,0)
  4882   ^^1^1^3131 105
  4883   "KRN",8994 ,815,3,1,0 )
  4884   Text array  formatted  as JSON
  4885   "KRN",8994 ,818,-1)
  4886   0^26
  4887   "KRN",8994 ,818,0)
  4888   VPR PUT DE MOGRAPHICS ^PUT^VPRUP D^4^S^^^0^ 1^^1
  4889   "KRN",8994 ,818,1,0)
  4890   ^8994.01^2 ^2^3131119 ^^
  4891   "KRN",8994 ,818,1,1,0 )
  4892   This RPC r eceives up dated phon e numbers  from the c lient and  calls
  4893   "KRN",8994 ,818,1,2,0 )
  4894   VAFCPTED t o save the m in the P atient fil e #2.
  4895   "KRN",8994 ,818,2,0)
  4896   ^8994.02A^ 3^3
  4897   "KRN",8994 ,818,2,1,0 )
  4898   OBJECT^3^^ ^3
  4899   "KRN",8994 ,818,2,1,1 ,0)
  4900   ^8994.021^ 1^1^313112 0^^^
  4901   "KRN",8994 ,818,2,1,1 ,1,0)
  4902   The data,  as a JSON  object
  4903   "KRN",8994 ,818,2,2,0 )
  4904   COMMAND^1^ ^^2
  4905   "KRN",8994 ,818,2,2,1 ,0)
  4906   ^8994.021^ 1^1^313112 0^^
  4907   "KRN",8994 ,818,2,2,1 ,1,0)
  4908   The action  to take o n the obje ct in Vist A
  4909   "KRN",8994 ,818,2,3,0 )
  4910   PATIENT^1^ ^^1
  4911   "KRN",8994 ,818,2,3,1 ,0)
  4912   ^^1^1^3131 120^
  4913   "KRN",8994 ,818,2,3,1 ,1,0)
  4914   Patient fi le #2 ien
  4915   "KRN",8994 ,818,2,"B" ,"COMMAND" ,2)
  4916  
  4917   "KRN",8994 ,818,2,"B" ,"OBJECT", 1)
  4918  
  4919   "KRN",8994 ,818,2,"B" ,"PATIENT" ,3)
  4920  
  4921   "KRN",8994 ,818,2,"PA RAMSEQ",1, 3)
  4922  
  4923   "KRN",8994 ,818,2,"PA RAMSEQ",2, 2)
  4924  
  4925   "KRN",8994 ,818,2,"PA RAMSEQ",3, 1)
  4926  
  4927   "KRN",8994 ,818,3,0)
  4928   ^8994.03^1 ^1^3131120 ^^^^
  4929   "KRN",8994 ,818,3,1,0 )
  4930   Text array  formatted  as JSON
  4931   "KRN",8994 ,821,-1)
  4932   0^25
  4933   "KRN",8994 ,821,0)
  4934   VPRCRPC RP CCHAIN^CHA INRPC^VPRC RPC^3^P^0^ ^0^1^^1
  4935   "KRN",8994 ,821,2,0)
  4936   ^8994.02A^ 1^1
  4937   "KRN",8994 ,821,2,1,0 )
  4938   PARAMS^2^3 2000^1^1
  4939   "KRN",8994 ,821,2,"B" ,"PARAMS", 1)
  4940  
  4941   "KRN",8994 ,821,2,"PA RAMSEQ",1, 1)
  4942  
  4943   "KRN",8994 ,839,-1)
  4944   0^3
  4945   "KRN",8994 ,839,0)
  4946   VPR SUBSCR IBE^SUBS^V PRPATS^4^S ^^^1^^^1
  4947   "KRN",8994 ,839,1,0)
  4948   ^8994.01^3 ^3^3130417 ^^^^
  4949   "KRN",8994 ,839,1,1,0 )
  4950   This RPC w ill mainta in a list  of patient s & events  to monito r for new  data.
  4951   "KRN",8994 ,839,1,2,0 )
  4952   The LIST o f patients  passed in to this RP C is retur ned in ^TM P($J,"VPR" ,n)
  4953   "KRN",8994 ,839,1,3,0 )
  4954   as XML, wi th a subsc ription st atus of 'o n', 'off',  or 'error '.
  4955   "KRN",8994 ,839,2,0)
  4956   ^8994.02A^ 3^3
  4957   "KRN",8994 ,839,2,1,0 )
  4958   SYS^1^^0^1
  4959   "KRN",8994 ,839,2,1,1 ,0)
  4960   ^8994.021^ 3^3^313041 7^^^^
  4961   "KRN",8994 ,839,2,1,1 ,1,0)
  4962   This is th e name of  the system  calling t he RPC; it  is used t o create
  4963   "KRN",8994 ,839,2,1,1 ,2,0)
  4964   an entry i n the VPR  SUBSCRIPTI ON file, a nd link a  system to  a list of
  4965   "KRN",8994 ,839,2,1,1 ,3,0)
  4966   patients a nd/or even ts.
  4967   "KRN",8994 ,839,2,2,0 )
  4968   LIST^2^^0^ 3
  4969   "KRN",8994 ,839,2,2,1 ,0)
  4970   ^8994.021^ 2^2^311031 0^^^
  4971   "KRN",8994 ,839,2,2,1 ,1,0)
  4972   This is th e list of  patient id entifiers,  in the fo rm 'dfn;ic n', that
  4973   "KRN",8994 ,839,2,2,1 ,2,0)
  4974   are to be  either add ed to or r emoved fro m the moni tor.
  4975   "KRN",8994 ,839,2,3,0 )
  4976   STS^1^^0^2
  4977   "KRN",8994 ,839,2,3,1 ,0)
  4978   ^^2^2^3110 310^
  4979   "KRN",8994 ,839,2,3,1 ,1,0)
  4980   This is a  boolean va lue, 1 or  0, indicat ing if the  patient s hould be
  4981   "KRN",8994 ,839,2,3,1 ,2,0)
  4982   added to o r removed  from the d ata monito r.
  4983   "KRN",8994 ,839,2,"B" ,"LIST",2)
  4984  
  4985   "KRN",8994 ,839,2,"B" ,"STS",3)
  4986  
  4987   "KRN",8994 ,839,2,"B" ,"SYS",1)
  4988  
  4989   "KRN",8994 ,839,2,"PA RAMSEQ",1, 1)
  4990  
  4991   "KRN",8994 ,839,2,"PA RAMSEQ",2, 3)
  4992  
  4993   "KRN",8994 ,839,2,"PA RAMSEQ",3, 2)
  4994  
  4995   "KRN",8994 ,839,3,0)
  4996   ^8994.03^1 ^1^3130417 ^^^^
  4997   "KRN",8994 ,839,3,1,0 )
  4998   Text array  formatted  as XML.
  4999   "KRN",8994 ,846,-1)
  5000   0^1
  5001   "KRN",8994 ,846,0)
  5002   VPR APPOIN TMENTS^OUT ^VPRPATS^4 ^S^^^1^^^1
  5003   "KRN",8994 ,846,1,0)
  5004   ^8994.01^2 ^2^3101129 ^^
  5005   "KRN",8994 ,846,1,1,0 )
  5006   This RPC f inds a lis t of patie nts that h ave schedu led appoin tments dur ing
  5007   "KRN",8994 ,846,1,2,0 )
  5008   the reques ted timefr ame, as XM L in ^TMP( $J,"VPR",n ).
  5009   "KRN",8994 ,846,2,0)
  5010   ^8994.02A^ 2^2
  5011   "KRN",8994 ,846,2,1,0 )
  5012   START^1^20 ^0^1
  5013   "KRN",8994 ,846,2,1,1 ,0)
  5014   ^8994.021^ 2^2^310112 9^^^
  5015   "KRN",8994 ,846,2,1,1 ,1,0)
  5016   The date/t ime from w hich to be gin search ing for ap pointments ; optional ,
  5017   "KRN",8994 ,846,2,1,1 ,2,0)
  5018   will defau lt to tomo rrow if no t defined.
  5019   "KRN",8994 ,846,2,2,0 )
  5020   STOP^1^20^ 0^2
  5021   "KRN",8994 ,846,2,2,1 ,0)
  5022   ^8994.021^ 2^2^310112 9^^
  5023   "KRN",8994 ,846,2,2,1 ,1,0)
  5024   The date/t ime at whi ch to end  searching  for appoin tments; op tional,
  5025   "KRN",8994 ,846,2,2,1 ,2,0)
  5026   will defau lt to tomo rrow if no t defined.
  5027   "KRN",8994 ,846,2,"B" ,"START",1 )
  5028  
  5029   "KRN",8994 ,846,2,"B" ,"STOP",2)
  5030  
  5031   "KRN",8994 ,846,2,"PA RAMSEQ",1, 1)
  5032  
  5033   "KRN",8994 ,846,2,"PA RAMSEQ",2, 2)
  5034  
  5035   "KRN",8994 ,846,3,0)
  5036   ^8994.03^1 ^1^3101129 ^^
  5037   "KRN",8994 ,846,3,1,0 )
  5038   Text array  formatted  XML
  5039   "KRN",8994 ,848,-1)
  5040   0^2
  5041   "KRN",8994 ,848,0)
  5042   VPR INPATI ENTS^IN^VP RPATS^4^S^ ^^1^^^1
  5043   "KRN",8994 ,848,1,0)
  5044   ^8994.01^2 ^2^3101129 ^^^
  5045   "KRN",8994 ,848,1,1,0 )
  5046   This RPC f inds a lis t of patie nts that a re current ly admitte d,
  5047   "KRN",8994 ,848,1,2,0 )
  5048   as XML in  ^TMP($J,"V PR",n).
  5049   "KRN",8994 ,848,2,0)
  5050   ^8994.02A^ ^0
  5051   "KRN",8994 ,848,3,0)
  5052   ^8994.03^1 ^1^3101129 ^^^
  5053   "KRN",8994 ,848,3,1,0 )
  5054   Text array  formatted  XML
  5055   "KRN",8994 ,849,-1)
  5056   0^27
  5057   "KRN",8994 ,849,0)
  5058   VPRDJFS AP I^API^VPRD JFS^4^^^^0
  5059   "KRN",8994 ,1342,-1)
  5060   0^28
  5061   "KRN",8994 ,1342,0)
  5062   VPRDJFS DE LSUB^DELSU B^VPRDJFS^ 1^P^0
  5063   "KRN",8994 ,1345,-1)
  5064   0^4
  5065   "KRN",8994 ,1345,0)
  5066   VPRCORD RP C^RPC^VPRC ORD^3^^^^0
  5067   "KRN",8994 ,1345,2,0)
  5068   ^8994.02A^ 1^1
  5069   "KRN",8994 ,1345,2,1, 0)
  5070   PARAMS^2^^ 1^1
  5071   "KRN",8994 ,1345,2,"B ","PARAMS" ,1)
  5072  
  5073   "KRN",8994 ,1345,2,"P ARAMSEQ",1 ,1)
  5074  
  5075   "KRN",8994 ,1346,-1)
  5076   0^5
  5077   "KRN",8994 ,1346,0)
  5078   VPRCPAT RP C^RPC^VPRC PAT^4
  5079   "KRN",8994 ,1346,2,0)
  5080   ^8994.02A^ 1^1
  5081   "KRN",8994 ,1346,2,1, 0)
  5082   PARAMS^2^^ 1^1
  5083   "KRN",8994 ,1346,2,"B ","PARAMS" ,1)
  5084  
  5085   "KRN",8994 ,1346,2,"P ARAMSEQ",1 ,1)
  5086  
  5087   "KRN",8994 ,1347,-1)
  5088   0^9
  5089   "KRN",8994 ,1347,0)
  5090   VPR ROSTER  PATIENTS^ COMPILE^VP RROS2^4^P^ ^^1^1^^1
  5091   "KRN",8994 ,1347,1,0)
  5092   ^8994.01^1 ^1^3120105 ^^^^
  5093   "KRN",8994 ,1347,1,1, 0)
  5094   Provides p atients as sociated w ith reques ted Roster .
  5095   "KRN",8994 ,1347,2,0)
  5096   ^8994.02A^ 2^2
  5097   "KRN",8994 ,1347,2,1, 0)
  5098   ROSTER^1^1 5^0^1
  5099   "KRN",8994 ,1347,2,1, 1,0)
  5100   ^8994.021^ 1^1^312010 5^^^^
  5101   "KRN",8994 ,1347,2,1, 1,1,0)
  5102   IEN of Ros ter you ar e requesti ng patient s for.
  5103   "KRN",8994 ,1347,2,2, 0)
  5104   OWNER^1^15 ^0^2
  5105   "KRN",8994 ,1347,2,2, 1,0)
  5106   ^^1^1^3120 105^
  5107   "KRN",8994 ,1347,2,2, 1,1,0)
  5108   Compile al l rosters  for this o wner.
  5109   "KRN",8994 ,1347,2,"B ","OWNER", 2)
  5110  
  5111   "KRN",8994 ,1347,2,"B ","ROSTER" ,1)
  5112  
  5113   "KRN",8994 ,1347,2,"P ARAMSEQ",1 ,1)
  5114  
  5115   "KRN",8994 ,1347,2,"P ARAMSEQ",2 ,2)
  5116  
  5117   "KRN",8994 ,1347,3,0)
  5118   ^8994.03^1 ^1^3120105 ^^^^
  5119   "KRN",8994 ,1347,3,1, 0)
  5120   Text array  formated  XML.
  5121   "KRN",8994 ,1350,-1)
  5122   0^10
  5123   "KRN",8994 ,1350,0)
  5124   VPR ROSTER S^GETROS^V PRROS2^4^P ^^^1^1^^1
  5125   "KRN",8994 ,1350,1,0)
  5126   ^8994.01^1 ^1^3111110 ^^^^
  5127   "KRN",8994 ,1350,1,1, 0)
  5128   Creates XM L list of  all Roster s.
  5129   "KRN",8994 ,1350,2,0)
  5130   ^8994.02A^ 1^1
  5131   "KRN",8994 ,1350,2,1, 0)
  5132   VPRFILT^1^ 30^0^1
  5133   "KRN",8994 ,1350,2,1, 1,0)
  5134   ^8994.021^ 1^1^311111 0^^
  5135   "KRN",8994 ,1350,2,1, 1,1,0)
  5136   Filter ros ters if fi lter not n ull.
  5137   "KRN",8994 ,1350,2,"B ","VPRFILT ",1)
  5138  
  5139   "KRN",8994 ,1350,2,"P ARAMSEQ",1 ,1)
  5140  
  5141   "KRN",8994 ,1350,3,0)
  5142   ^8994.03^1 ^1^3111110 ^^^^
  5143   "KRN",8994 ,1350,3,1, 0)
  5144   Text array  formatted  in XML.
  5145   "KRN",8994 ,1351,-1)
  5146   0^12
  5147   "KRN",8994 ,1351,0)
  5148   VPR PREVIE W ROSTER^P REVIEW^VPR ROS3^4^P^^ ^1^1^^1
  5149   "KRN",8994 ,1351,1,0)
  5150   ^8994.01^1 ^1^3120131 ^^^^
  5151   "KRN",8994 ,1351,1,1, 0)
  5152   Compiles R oster base d on data  passed fro m GUI Inte rface.
  5153   "KRN",8994 ,1351,2,0)
  5154   ^8994.02A^ 1^1
  5155   "KRN",8994 ,1351,2,1, 0)
  5156   VPRARRAY^2 ^32000^1^1
  5157   "KRN",8994 ,1351,2,1, 1,0)
  5158   ^8994.021^ 1^1^311102 2^^^^
  5159   "KRN",8994 ,1351,2,1, 1,1,0)
  5160   Roster dat a from GUI .
  5161   "KRN",8994 ,1351,2,"B ","VPRARRA Y",1)
  5162  
  5163   "KRN",8994 ,1351,2,"P ARAMSEQ",1 ,1)
  5164  
  5165   "KRN",8994 ,1351,3,0)
  5166   ^8994.03^1 ^1^3111022 ^^^^
  5167   "KRN",8994 ,1351,3,1, 0)
  5168   XML format ted Roster .
  5169   "KRN",8994 ,1352,-1)
  5170   0^11
  5171   "KRN",8994 ,1352,0)
  5172   VPR UPDATE  ROSTER^UP DATE^VPRRO S3^4^P^^^1 ^1^^1
  5173   "KRN",8994 ,1352,1,0)
  5174   ^8994.01^1 ^1^3111031 ^^
  5175   "KRN",8994 ,1352,1,1, 0)
  5176   Udates ros ter data e ditted by  GUI into V istA.
  5177   "KRN",8994 ,1352,2,0)
  5178   ^8994.02A^ 1^1
  5179   "KRN",8994 ,1352,2,1, 0)
  5180   VPRARRAY^2 ^32000^1^1
  5181   "KRN",8994 ,1352,2,"B ","VPRARRA Y",1)
  5182  
  5183   "KRN",8994 ,1352,2,"P ARAMSEQ",1 ,1)
  5184  
  5185   "KRN",8994 ,1360,-1)
  5186   0^13
  5187   "KRN",8994 ,1360,0)
  5188   VPR GET SO URCE^GETSR C^VPRROS4^ 4^P^^^1^1^ ^1
  5189   "KRN",8994 ,1360,1,0)
  5190   ^8994.01^2 ^2^3111101 ^^
  5191   "KRN",8994 ,1360,1,1, 0)
  5192   Get all so urce infor mation for  requested  source.   For exampl e, Request  is for Cl inics.  Tr ansmit all  active cl inics
  5193   "KRN",8994 ,1360,1,2, 0)
  5194   include na me and ien .
  5195   "KRN",8994 ,1360,2,0)
  5196   ^8994.02A^ 2^2
  5197   "KRN",8994 ,1360,2,1, 0)
  5198   VPRSRC^1^3 0^1^1
  5199   "KRN",8994 ,1360,2,1, 1,0)
  5200   ^^1^1^3111 031^
  5201   "KRN",8994 ,1360,2,1, 1,1,0)
  5202   Identifies  which sou rce inform ation to s end to the  GUI.
  5203   "KRN",8994 ,1360,2,2, 0)
  5204   VPRFILT^1^ 30^0^2
  5205   "KRN",8994 ,1360,2,2, 1,0)
  5206   ^8994.021^ 1^1^311110 3^^
  5207   "KRN",8994 ,1360,2,2, 1,1,0)
  5208   Text ident ifying wha t you are  looking fo r.  Will b e used whe n matching  for detai ls.
  5209   "KRN",8994 ,1360,2,"B ","VPRFILT ",2)
  5210  
  5211   "KRN",8994 ,1360,2,"B ","VPRSRC" ,1)
  5212  
  5213   "KRN",8994 ,1360,2,"P ARAMSEQ",1 ,1)
  5214  
  5215   "KRN",8994 ,1360,2,"P ARAMSEQ",2 ,2)
  5216  
  5217   "KRN",8994 ,1360,3,0)
  5218   ^8994.03^1 ^1^3111101 ^^
  5219   "KRN",8994 ,1360,3,1, 0)
  5220   An array c ontaining  names and  ien's of s ource data .
  5221   "KRN",8994 ,1464,-1)
  5222   0^7
  5223   "KRN",8994 ,1464,0)
  5224   VPRFPTC CH KS^CHKS^VP RFPTC^3^^^ ^0
  5225   "KRN",8994 ,1464,1,0)
  5226   ^8994.01^2 ^2^3120629 ^^^
  5227   "KRN",8994 ,1464,1,1, 0)
  5228   This RPC r eturns the  patient s election c hecks for  a sensitiv e patient,  
  5229   "KRN",8994 ,1464,1,2, 0)
  5230   deceased,  and PRF.
  5231   "KRN",8994 ,1464,2,0)
  5232   ^8994.02A^ 1^1
  5233   "KRN",8994 ,1464,2,1, 0)
  5234   ICN^1^^1^1
  5235   "KRN",8994 ,1464,2,1, 1,0)
  5236   ^8994.021^ 1^1^312062 9^^
  5237   "KRN",8994 ,1464,2,1, 1,1,0)
  5238   This is th e patient  ICN
  5239   "KRN",8994 ,1464,2,"B ","ICN",1)
  5240  
  5241   "KRN",8994 ,1464,2,"P ARAMSEQ",1 ,1)
  5242  
  5243   "KRN",8994 ,1466,-1)
  5244   0^15
  5245   "KRN",8994 ,1466,0)
  5246   VPRCRPC RP C^RPC^VPRC RPC^3^^^^0
  5247   "KRN",8994 ,1466,1,0)
  5248   ^8994.01^2 ^2^3120515 ^^
  5249   "KRN",8994 ,1466,1,1, 0)
  5250   This RPC i s used to  save and g et data to /from the  VPR PARAME TERS in th
  5251   "KRN",8994 ,1466,1,2, 0)
  5252   parameter  file.
  5253   "KRN",8994 ,1466,2,0)
  5254   ^8994.02A^ 1^1
  5255   "KRN",8994 ,1466,2,1, 0)
  5256   PARAMS^2^^ 1^1
  5257   "KRN",8994 ,1466,2,"B ","PARAMS" ,1)
  5258  
  5259   "KRN",8994 ,1466,2,"P ARAMSEQ",1 ,1)
  5260  
  5261   "KRN",8994 ,1467,-1)
  5262   0^8
  5263   "KRN",8994 ,1467,0)
  5264   VPRFPTC LO G^LOG^VPRF PTC^3^^^^0
  5265   "KRN",8994 ,1467,1,0)
  5266   ^8994.01^2 ^2^3120124 ^
  5267   "KRN",8994 ,1467,1,1, 0)
  5268   This RPC i s used to  log a pati ent when a  provider  is accessi ng a 
  5269   "KRN",8994 ,1467,1,2, 0)
  5270   sensitive  record.
  5271   "KRN",8994 ,1467,2,0)
  5272   ^8994.02A^ 1^1
  5273   "KRN",8994 ,1467,2,1, 0)
  5274   ICN^1^^1^1
  5275   "KRN",8994 ,1467,2,"B ","ICN",1)
  5276  
  5277   "KRN",8994 ,1467,2,"P ARAMSEQ",1 ,1)
  5278  
  5279   "KRN",8994 ,1468,-1)
  5280   0^14
  5281   "KRN",8994 ,1468,0)
  5282   VPR DELETE  ROSTER^DE LROS^VPRRO S3^1^^^^^1 .2
  5283   "KRN",8994 ,1468,2,0)
  5284   ^8994.02A^ 1^1
  5285   "KRN",8994 ,1468,2,1, 0)
  5286   VPRIEN^1^1 00^1^1
  5287   "KRN",8994 ,1468,2,1, 1,0)
  5288   ^8994.021^ 1^1^313121 0^^
  5289   "KRN",8994 ,1468,2,1, 1,1,0)
  5290   Roster IEN .
  5291   "KRN",8994 ,1468,2,"B ","VPRIEN" ,1)
  5292  
  5293   "KRN",8994 ,1468,2,"P ARAMSEQ",1 ,1)
  5294  
  5295   "KRN",8994 ,2949,-1)
  5296   0^21
  5297   "KRN",8994 ,2949,0)
  5298   VPR PUT PA TIENT DATA ^PUT^VPRDJ 1^1^S^^^1^ 1^^1
  5299   "KRN",8994 ,2949,1,0)
  5300   ^8994.01^2 ^2^3121129 ^^^^
  5301   "KRN",8994 ,2949,1,1, 0)
  5302   This RPC r eceives da ta from th e client a nd saves i t in the V PR Patient
  5303   "KRN",8994 ,2949,1,2, 0)
  5304   Object fil e #560.1 a s JSON.
  5305   "KRN",8994 ,2949,2,0)
  5306   ^8994.02A^ 3^3
  5307   "KRN",8994 ,2949,2,1, 0)
  5308   DFN^1^20^1 ^1
  5309   "KRN",8994 ,2949,2,1, 1,0)
  5310   ^8994.021^ 2^2^312101 0^^^
  5311   "KRN",8994 ,2949,2,1, 1,1,0)
  5312   Internal e ntry numbe r from Pat ient file  #2
  5313   "KRN",8994 ,2949,2,1, 1,2,0)
  5314   [optionall y DFN;ICN  for remote  calls]
  5315   "KRN",8994 ,2949,2,2, 0)
  5316   TYPE^1^100 ^0^2
  5317   "KRN",8994 ,2949,2,2, 1,0)
  5318   ^8994.021^ 1^1^312101 0^^^^
  5319   "KRN",8994 ,2949,2,2, 1,1,0)
  5320   The kind o f data bei ng stored.
  5321   "KRN",8994 ,2949,2,3, 0)
  5322   OBJECT^3^^ 0^3
  5323   "KRN",8994 ,2949,2,3, 1,0)
  5324   ^8994.021^ 1^1^312112 9^^^^
  5325   "KRN",8994 ,2949,2,3, 1,1,0)
  5326   The conten t of the o bject, as  JSON
  5327   "KRN",8994 ,2949,2,"B ","DFN",1)
  5328  
  5329   "KRN",8994 ,2949,2,"B ","OBJECT" ,3)
  5330  
  5331   "KRN",8994 ,2949,2,"B ","TYPE",2 )
  5332  
  5333   "KRN",8994 ,2949,2,"P ARAMSEQ",1 ,1)
  5334  
  5335   "KRN",8994 ,2949,2,"P ARAMSEQ",2 ,2)
  5336  
  5337   "KRN",8994 ,2949,2,"P ARAMSEQ",3 ,3)
  5338  
  5339   "KRN",8994 ,2949,3,0)
  5340   ^8994.03^1 ^1^3121129 ^^^^
  5341   "KRN",8994 ,2949,3,1, 0)
  5342   Text array  formatted  as JSON
  5343   "KRN",8994 ,2950,-1)
  5344   0^20
  5345   "KRN",8994 ,2950,0)
  5346   VPR PUT OB JECT^PUT^V PRDJ2^1^S^ ^^1^1^^1
  5347   "KRN",8994 ,2950,1,0)
  5348   ^8994.01^2 ^2^3131216 ^^^^
  5349   "KRN",8994 ,2950,1,1, 0)
  5350   This RPC r eceives da ta from th e client a nd saves i t in the V PR Object
  5351   "KRN",8994 ,2950,1,2, 0)
  5352   file #560. 11 as JSON .
  5353   "KRN",8994 ,2950,2,0)
  5354   ^8994.02A^ 3^2
  5355   "KRN",8994 ,2950,2,2, 0)
  5356   TYPE^1^100 ^0^1
  5357   "KRN",8994 ,2950,2,2, 1,0)
  5358   ^8994.021^ 1^1^312112 9^^^^
  5359   "KRN",8994 ,2950,2,2, 1,1,0)
  5360   The kind o f data bei ng stored.
  5361   "KRN",8994 ,2950,2,3, 0)
  5362   OBJECT^3^^ 0^2
  5363   "KRN",8994 ,2950,2,3, 1,0)
  5364   ^8994.021^ 1^1^312112 9^^^^
  5365   "KRN",8994 ,2950,2,3, 1,1,0)
  5366   The conten t of the o bject, as  JSON
  5367   "KRN",8994 ,2950,2,"B ","OBJECT" ,3)
  5368  
  5369   "KRN",8994 ,2950,2,"B ","TYPE",2 )
  5370  
  5371   "KRN",8994 ,2950,2,"P ARAMSEQ",1 ,2)
  5372  
  5373   "KRN",8994 ,2950,2,"P ARAMSEQ",2 ,3)
  5374  
  5375   "KRN",8994 ,2950,3,0)
  5376   ^8994.03^1 ^1^3121129 ^^^^
  5377   "KRN",8994 ,2950,3,1, 0)
  5378   Text array  formatted  as JSON
  5379   "KRN",8994 ,2953,-1)
  5380   0^17
  5381   "KRN",8994 ,2953,0)
  5382   VPR GET OB JECT^GET^V PRDJ2^4^S^ ^^0^1^^1
  5383   "KRN",8994 ,2953,1,0)
  5384   ^8994.01^2 ^2^3121219 ^^^^
  5385   "KRN",8994 ,2953,1,1, 0)
  5386   This RPC r etrieves t he request ed data fr om VistA,  and return s it in
  5387   "KRN",8994 ,2953,1,2, 0)
  5388   ^TMP("VPR" ,$J,n) as  JSON.
  5389   "KRN",8994 ,2953,2,0)
  5390   ^8994.02A^ 1^1
  5391   "KRN",8994 ,2953,2,1, 0)
  5392   FILTER^2^^ 0^1
  5393   "KRN",8994 ,2953,2,1, 1,0)
  5394   ^8994.021^ 1^1^312121 9^^^^
  5395   "KRN",8994 ,2953,2,1, 1,1,0)
  5396   List of na me-value p airs defin ing the se arch.
  5397   "KRN",8994 ,2953,2,"B ","FILTER" ,1)
  5398  
  5399   "KRN",8994 ,2953,2,"P ARAMSEQ",1 ,1)
  5400  
  5401   "KRN",8994 ,2953,3,0)
  5402   ^8994.03^1 ^1^3121219 ^^^^
  5403   "KRN",8994 ,2953,3,1, 0)
  5404   Text array  formatted  as JSON
  5405   "KRN",8994 ,2954,-1)
  5406   0^16
  5407   "KRN",8994 ,2954,0)
  5408   VPR DELETE  OBJECT^DE L^VPRDJ2^1 ^S^^^1^1^^ 1
  5409   "KRN",8994 ,2954,1,0)
  5410   ^8994.01^2 ^2^3130103 ^^^^
  5411   "KRN",8994 ,2954,1,1, 0)
  5412   This RPC r eceives a  Uid from t he client  and delete s the obje ct from th e
  5413   "KRN",8994 ,2954,1,2, 0)
  5414   VPR Object  file #560 .11.
  5415   "KRN",8994 ,2954,2,0)
  5416   ^8994.02A^ 2^1
  5417   "KRN",8994 ,2954,2,2, 0)
  5418   UID^1^100^ 1^1
  5419   "KRN",8994 ,2954,2,2, 1,0)
  5420   ^8994.021^ 1^1^313010 3^^^^
  5421   "KRN",8994 ,2954,2,2, 1,1,0)
  5422   The Uid of  the objec t being de leted.
  5423   "KRN",8994 ,2954,2,"B ","UID",2)
  5424  
  5425   "KRN",8994 ,2954,2,"P ARAMSEQ",1 ,2)
  5426  
  5427   "KRN",8994 ,2954,3,0)
  5428   ^8994.03^1 ^1^3130103 ^^^^
  5429   "KRN",8994 ,2954,3,1, 0)
  5430   Text array  formatted  as JSON
  5431   "KRN",8994 ,2955,-1)
  5432   0^19
  5433   "KRN",8994 ,2955,0)
  5434   VPR GET RO STER LIST^ GET^VPRROS 7^4^S^^^^1 ^^1
  5435   "KRN",8994 ,2955,1,0)
  5436   ^8994.01^2 ^2^3130221 ^^
  5437   "KRN",8994 ,2955,1,1, 0)
  5438   Patient id entificati on data pa ssed in an d roster i dentificat ion return ed.
  5439   "KRN",8994 ,2955,1,2, 0)
  5440   List will  contain al l rosters  associated  with pati ent.
  5441   "KRN",8994 ,2955,2,0)
  5442   ^8994.02A^ 2^2
  5443   "KRN",8994 ,2955,2,1, 0)
  5444   VPR^2^3200 ^1^1
  5445   "KRN",8994 ,2955,2,2, 0)
  5446   VPRARRAY^2 ^3200^1^1
  5447   "KRN",8994 ,2955,2,"B ","VPR",1)
  5448  
  5449   "KRN",8994 ,2955,2,"B ","VPRARRA Y",2)
  5450  
  5451   "KRN",8994 ,2955,2,"P ARAMSEQ",1 ,1)
  5452  
  5453   "KRN",8994 ,2955,2,"P ARAMSEQ",1 ,2)
  5454  
  5455   "KRN",8994 ,2956,-1)
  5456   0^18
  5457   "KRN",8994 ,2956,0)
  5458   VPR GET OP ERATIONAL  DATA^GET^V PREF^4^S^^ ^0^1^^1
  5459   "KRN",8994 ,2956,1,0)
  5460   ^8994.01^2 ^2^3130507 ^^^^
  5461   "KRN",8994 ,2956,1,1, 0)
  5462   This RPC r etrieves t he request ed data fr om VistA,  and return s it in
  5463   "KRN",8994 ,2956,1,2, 0)
  5464   ^TMP("VPR" ,$J,n) as  JSON.
  5465   "KRN",8994 ,2956,2,0)
  5466   ^8994.02A^ 1^1
  5467   "KRN",8994 ,2956,2,1, 0)
  5468   FILTER^2^^ 0^1
  5469   "KRN",8994 ,2956,2,1, 1,0)
  5470   ^8994.021^ 1^1^313050 7^^^^
  5471   "KRN",8994 ,2956,2,1, 1,1,0)
  5472   List of na me-value p airs defin ing the se arch.
  5473   "KRN",8994 ,2956,2,"B ","FILTER" ,1)
  5474  
  5475   "KRN",8994 ,2956,2,"P ARAMSEQ",1 ,1)
  5476  
  5477   "KRN",8994 ,2956,3,0)
  5478   ^8994.03^1 ^1^3130507 ^^^^
  5479   "KRN",8994 ,2956,3,1, 0)
  5480   Text array  formatted  as JSON
  5481   "KRN",8994 ,2965,-1)
  5482   0^23
  5483   "KRN",8994 ,2965,0)
  5484   VPR SUBSCR IBE ROSTER S^SUBS^VPR ROS7^4^S^^ ^1^^^1
  5485   "KRN",8994 ,2965,1,0)
  5486   ^8994.01^3 ^3^3130417 ^^^^
  5487   "KRN",8994 ,2965,1,1, 0)
  5488   This RPC w ill mainta in a list  of rosters  to monito r for new  patients.
  5489   "KRN",8994 ,2965,1,2, 0)
  5490   The LIST o f rosters  passed int o this RPC  is return ed in ^TMP ($J,"VPR", n)
  5491   "KRN",8994 ,2965,1,3, 0)
  5492   as XML, wi th a subsc ription st atus of 'o n', 'off',  or 'error '.
  5493   "KRN",8994 ,2965,2,0)
  5494   ^8994.02A^ 3^3
  5495   "KRN",8994 ,2965,2,1, 0)
  5496   SYS^1^^0^1
  5497   "KRN",8994 ,2965,2,1, 1,0)
  5498   ^8994.021^ 3^3^313041 7^^^^
  5499   "KRN",8994 ,2965,2,1, 1,1,0)
  5500   This is th e name of  the system  calling t he RPC; it  is used t o create
  5501   "KRN",8994 ,2965,2,1, 1,2,0)
  5502   an entry i n the VPR  SUBSCRIPTI ON file, a nd link a  system to  a list of
  5503   "KRN",8994 ,2965,2,1, 1,3,0)
  5504   rosters.
  5505   "KRN",8994 ,2965,2,2, 0)
  5506   LIST^2^^0^ 3
  5507   "KRN",8994 ,2965,2,2, 1,0)
  5508   ^8994.021^ 2^2^313041 7^^^^
  5509   "KRN",8994 ,2965,2,2, 1,1,0)
  5510   This is th e list of  roster ide ntifiers t hat are to  be either  added to  or
  5511   "KRN",8994 ,2965,2,2, 1,2,0)
  5512   removed fr om the mon itor.
  5513   "KRN",8994 ,2965,2,3, 0)
  5514   STS^1^^0^2
  5515   "KRN",8994 ,2965,2,3, 1,0)
  5516   ^8994.021^ 2^2^313041 7^^
  5517   "KRN",8994 ,2965,2,3, 1,1,0)
  5518   This is a  boolean va lue, 1 or  0, indicat ing if the  roster sh ould be
  5519   "KRN",8994 ,2965,2,3, 1,2,0)
  5520   added to o r removed  from the d ata monito r.
  5521   "KRN",8994 ,2965,2,"B ","LIST",2 )
  5522  
  5523   "KRN",8994 ,2965,2,"B ","STS",3)
  5524  
  5525   "KRN",8994 ,2965,2,"B ","SYS",1)
  5526  
  5527   "KRN",8994 ,2965,2,"P ARAMSEQ",1 ,1)
  5528  
  5529   "KRN",8994 ,2965,2,"P ARAMSEQ",2 ,3)
  5530  
  5531   "KRN",8994 ,2965,2,"P ARAMSEQ",3 ,2)
  5532  
  5533   "KRN",8994 ,2965,3,0)
  5534   ^8994.03^1 ^1^3130417 ^^^^
  5535   "KRN",8994 ,2965,3,1, 0)
  5536   Text array  formatted  as XML.
  5537   "KRN",8994 ,2973,-1)
  5538   0^24
  5539   "KRN",8994 ,2973,0)
  5540   VPRCPRS RP C^RPC^VPRC PRS^3^^^^0
  5541   "KRN",8994 ,2973,2,0)
  5542   ^8994.02A^ 1^1
  5543   "KRN",8994 ,2973,2,1, 0)
  5544   PARAMS^2^^ 1^1
  5545   "KRN",8994 ,2973,2,"B ","PARAMS" ,1)
  5546  
  5547   "KRN",8994 ,2973,2,"P ARAMSEQ",1 ,1)
  5548  
  5549   "MBREQ")
  5550   1
  5551   "ORD",0,9. 8)
  5552   9.8;;1;RTN F^XPDTA;RT NE^XPDTA
  5553   "ORD",0,9. 8,0)
  5554   ROUTINE
  5555   "ORD",3,19 .1)
  5556   19.1;3;;;K EY^XPDTA1; KEYF1^XPDI A1;KEYE1^X PDIA1;KEYF 2^XPDIA1;; KEYDEL^XPD IA1
  5557   "ORD",3,19 .1,0)
  5558   SECURITY K EY
  5559   "ORD",14,7 71)
  5560   771;14;;;H LAP^XPDTA1 ;HLAPF1^XP DIA1;HLAPE 1^XPDIA1;H LAPF2^XPDI A1;;HLAPDE L^XPDIA1(% )
  5561   "ORD",14,7 71,0)
  5562   HL7 APPLIC ATION PARA METER
  5563   "ORD",15,1 01)
  5564   101;15;;;P RO^XPDTA;P ROF1^XPDIA ;PROE1^XPD IA;PROF2^X PDIA;;PROD EL^XPDIA
  5565   "ORD",15,1 01,0)
  5566   PROTOCOL
  5567   "ORD",16,8 994)
  5568   8994;16;1; ;;;;;;RPCD EL^XPDIA1
  5569   "ORD",16,8 994,0)
  5570   REMOTE PRO CEDURE
  5571   "ORD",18,1 9)
  5572   19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
  5573   "ORD",18,1 9,0)
  5574   OPTION
  5575   "ORD",20,8 989.51)
  5576   8989.51;20 ;;;PAR1E1^ XPDTA2;PAR 1F1^XPDIA3 ;PAR1E1^XP DIA3;PAR1F 2^XPDIA3;; PAR1DEL^XP DIA3(%)
  5577   "ORD",20,8 989.51,0)
  5578   PARAMETER  DEFINITION
  5579   "PKG",571, -1)
  5580   1^1
  5581   "PKG",571, 0)
  5582   VIRTUAL PA TIENT RECO RD^VPR^Uti lities to  manage a v irtual cop y of the p atient rec ord
  5583   "PKG",571, 20,0)
  5584   ^9.402P^^
  5585   "PKG",571, 22,0)
  5586   ^9.49I^1^1
  5587   "PKG",571, 22,1,0)
  5588   1.0^311080 4^3110525^ 1085
  5589   "PKG",571, 22,1,"PAH" ,1,0)
  5590   3^3140611^ 1085
  5591   "PKG",571, 22,1,"PAH" ,1,1,0)
  5592   ^^2^2^3140 611
  5593   "PKG",571, 22,1,"PAH" ,1,1,1,0)
  5594   The Virtua l Patient  Record (VP R) monitor s a VistA  system for  new data
  5595   "PKG",571, 22,1,"PAH" ,1,1,2,0)
  5596   and activi ty, and ma kes that d ata availa ble to a s ubscribing  client.
  5597   "QUES","XP F1",0)
  5598   Y
  5599   "QUES","XP F1","??")
  5600   ^D REP^XPD H
  5601   "QUES","XP F1","A")
  5602   Shall I wr ite over y our |FLAG|  File
  5603   "QUES","XP F1","B")
  5604   YES
  5605   "QUES","XP F1","M")
  5606   D XPF1^XPD IQ
  5607   "QUES","XP F2",0)
  5608   Y
  5609   "QUES","XP F2","??")
  5610   ^D DTA^XPD H
  5611   "QUES","XP F2","A")
  5612   Want my da ta |FLAG|  yours
  5613   "QUES","XP F2","B")
  5614   YES
  5615   "QUES","XP F2","M")
  5616   D XPF2^XPD IQ
  5617   "QUES","XP I1",0)
  5618   YO
  5619   "QUES","XP I1","??")
  5620   ^D INHIBIT ^XPDH
  5621   "QUES","XP I1","A")
  5622   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  5623   "QUES","XP I1","B")
  5624   NO
  5625   "QUES","XP I1","M")
  5626   D XPI1^XPD IQ
  5627   "QUES","XP M1",0)
  5628   PO^VA(200, :EM
  5629   "QUES","XP M1","??")
  5630   ^D MG^XPDH
  5631   "QUES","XP M1","A")
  5632   Enter the  Coordinato r for Mail  Group '|F LAG|'
  5633   "QUES","XP M1","B")
  5634  
  5635   "QUES","XP M1","M")
  5636   D XPM1^XPD IQ
  5637   "QUES","XP O1",0)
  5638   Y
  5639   "QUES","XP O1","??")
  5640   ^D MENU^XP DH
  5641   "QUES","XP O1","A")
  5642   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  5643   "QUES","XP O1","B")
  5644   NO
  5645   "QUES","XP O1","M")
  5646   D XPO1^XPD IQ
  5647   "QUES","XP Z1",0)
  5648   Y
  5649   "QUES","XP Z1","??")
  5650   ^D OPT^XPD H
  5651   "QUES","XP Z1","A")
  5652   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  5653   "QUES","XP Z1","B")
  5654   NO
  5655   "QUES","XP Z1","M")
  5656   D XPZ1^XPD IQ
  5657   "QUES","XP Z2",0)
  5658   Y
  5659   "QUES","XP Z2","??")
  5660   ^D RTN^XPD H
  5661   "QUES","XP Z2","A")
  5662   Want to MO VE routine s to other  CPUs
  5663   "QUES","XP Z2","B")
  5664   NO
  5665   "QUES","XP Z2","M")
  5666   D XPZ2^XPD IQ
  5667   "RTN")
  5668   76
  5669   "RTN","VPR CAC")
  5670   0^92^B9374 8801
  5671   "RTN","VPR CAC",1,0)
  5672   VPRCAC ;SL C/AGP-- VP R CAC Tool s
  5673   "RTN","VPR CAC",2,0)
  5674    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Feb  06, 2014;B uild 283
  5675   "RTN","VPR CAC",3,0)
  5676    ;
  5677   "RTN","VPR CAC",4,0)
  5678    Q
  5679   "RTN","VPR CAC",5,0)
  5680    ;
  5681   "RTN","VPR CAC",6,0)
  5682   ASK(YESNO, PROMPT)       ;
  5683   "RTN","VPR CAC",7,0)
  5684    N X,Y,TEX T
  5685   "RTN","VPR CAC",8,0)
  5686    K DIROUT, DIRUT,DTOU T,DUOUT
  5687   "RTN","VPR CAC",9,0)
  5688    S DIR(0)= "YA0"
  5689   "RTN","VPR CAC",10,0)
  5690    S DIR("A" )=PROMPT
  5691   "RTN","VPR CAC",11,0)
  5692    S DIR("B" )="N"
  5693   "RTN","VPR CAC",12,0)
  5694    S DIR("?" )="Enter Y  or N. For  detailed  help type  ??"
  5695   "RTN","VPR CAC",13,0)
  5696    ;S DIR("? ?")=U_"D H ELP^PXRMLC R("_NUM_") "
  5697   "RTN","VPR CAC",14,0)
  5698    W !
  5699   "RTN","VPR CAC",15,0)
  5700    D ^DIR K  DIR
  5701   "RTN","VPR CAC",16,0)
  5702    I $D(DIRO UT) S DTOU T=1
  5703   "RTN","VPR CAC",17,0)
  5704    I $D(DTOU T)!($D(DUO UT)) Q
  5705   "RTN","VPR CAC",18,0)
  5706    S YESNO=$ E(Y(0))
  5707   "RTN","VPR CAC",19,0)
  5708    Q
  5709   "RTN","VPR CAC",20,0)
  5710    ;
  5711   "RTN","VPR CAC",21,0)
  5712   ADDSVR() ;
  5713   "RTN","VPR CAC",22,0)
  5714    N DIC,DLA YGO,Y
  5715   "RTN","VPR CAC",23,0)
  5716    S DIC="^V PR(560,",D IC(0)="AEM QL",DIC("A ")="Select  HMP serve r instance : ",DLAYGO =560
  5717   "RTN","VPR CAC",24,0)
  5718    D ^DIC
  5719   "RTN","VPR CAC",25,0)
  5720    Q Y
  5721   "RTN","VPR CAC",26,0)
  5722    ;
  5723   "RTN","VPR CAC",27,0)
  5724   OPTASGN()  ;
  5725   "RTN","VPR CAC",28,0)
  5726    N ARGS,DI C,DLAYGO,F DA,HASOPT, IEN,LIST,M SG,OPTNAME ,PAT,RESUL T,SVR,VPRE RR,VPROPT, Y,YESNO
  5727   "RTN","VPR CAC",29,0)
  5728    S OPTNAME ="VPR UI C ONTEXT"
  5729   "RTN","VPR CAC",30,0)
  5730    S VPROPT= $$FIND1^DI C(19,"","B ",OPTNAME, ,,"MSG") I  VPROPT'>0  W !,"Erro r: Could n ot find 'V PR UI CONT EXT' optio n." Q
  5731   "RTN","VPR CAC",31,0)
  5732    ;
  5733   "RTN","VPR CAC",32,0)
  5734    S Y=$$ADD SVR() I +Y <0 Q
  5735   "RTN","VPR CAC",33,0)
  5736    S SVR=$P( $G(^VPR(56 0,+Y,0)),U )
  5737   "RTN","VPR CAC",34,0)
  5738    ;
  5739   "RTN","VPR CAC",35,0)
  5740    K DLAYGO
  5741   "RTN","VPR CAC",36,0)
  5742    S DIC="^V A(200,",DI C(0)="AEMQ ",DIC("A") ="Select u ser to pro vide acces s to HMP:  "
  5743   "RTN","VPR CAC",37,0)
  5744    D ^DIC
  5745   "RTN","VPR CAC",38,0)
  5746    I +Y<0 Q
  5747   "RTN","VPR CAC",39,0)
  5748    S IEN=+Y
  5749   "RTN","VPR CAC",40,0)
  5750    ;
  5751   "RTN","VPR CAC",41,0)
  5752    S HASOPT= $$ACCESS^X QCHK(IEN,V PROPT)
  5753   "RTN","VPR CAC",42,0)
  5754    I +HASOPT >0 D  Q
  5755   "RTN","VPR CAC",43,0)
  5756    .W !,"Use r has 'VPR  UI CONTEX T' already  assigned. " D ASK(.Y ESNO,"Sync  user defa ult CPRS p atient lis t: ") I YE SNO'="Y" Q
  5757   "RTN","VPR CAC",44,0)
  5758    .I $G(YES NO)="Y" D  GETPATS(.R ESULT,IEN, SVR)
  5759   "RTN","VPR CAC",45,0)
  5760    ;
  5761   "RTN","VPR CAC",46,0)
  5762    K YESNO
  5763   "RTN","VPR CAC",47,0)
  5764    D ASK(.YE SNO,"Assig n 'VPR UI  CONTEXT':  ")
  5765   "RTN","VPR CAC",48,0)
  5766    I YESNO'= "Y" Q
  5767   "RTN","VPR CAC",49,0)
  5768    S FDA(200 .03,"+2,"_ IEN_",",.0 1)=VPROPT
  5769   "RTN","VPR CAC",50,0)
  5770    D UPDATE^ DIE("","FD A","","VPR ERR")
  5771   "RTN","VPR CAC",51,0)
  5772    I $D(VPRE RR) D  Q
  5773   "RTN","VPR CAC",52,0)
  5774    .D EN^DDI OL("Update  failed, U PDATE^DIE  returned t he followi ng error m essage.")
  5775   "RTN","VPR CAC",53,0)
  5776    .S IC="VP RERR"
  5777   "RTN","VPR CAC",54,0)
  5778    .F  S IC= $Q(@IC) Q: IC=""  W ! ,IC,"=",@I C
  5779   "RTN","VPR CAC",55,0)
  5780    D GETPATS (.RESULT,I EN,SVR)
  5781   "RTN","VPR CAC",56,0)
  5782    Q
  5783   "RTN","VPR CAC",57,0)
  5784    ;
  5785   "RTN","VPR CAC",58,0)
  5786   GETPATS(RE SULT,IEN,S RV) ;
  5787   "RTN","VPR CAC",59,0)
  5788    N ARGS,LI ST,PAT
  5789   "RTN","VPR CAC",60,0)
  5790    D GETDFLS T(.LIST,IE N)
  5791   "RTN","VPR CAC",61,0)
  5792    I '$D(LIS T) W !,"No  default p atient lis t found."  Q
  5793   "RTN","VPR CAC",62,0)
  5794    S ARGS("c ommand")=" putPtSubsc ription"
  5795   "RTN","VPR CAC",63,0)
  5796    S ARGS("s erver")=SR V
  5797   "RTN","VPR CAC",64,0)
  5798    S PAT=0 F   S PAT=$O (LIST(PAT) ) Q:PAT'>0   D
  5799   "RTN","VPR CAC",65,0)
  5800    .;check t o see if p atient is  already sy nc for the  server.
  5801   "RTN","VPR CAC",66,0)
  5802    .I $G(^VP R(560,"AIT EM",PAT,SR V))>0 W !, "Patient " _PAT_" alr eady synce d." Q
  5803   "RTN","VPR CAC",67,0)
  5804    .S ARGS(" localId")= PAT
  5805   "RTN","VPR CAC",68,0)
  5806    .W !,"Sta rting sync  on patien t: "_PAT
  5807   "RTN","VPR CAC",69,0)
  5808    .D API^VP RDJFS(.RES ULT,.ARGS)
  5809   "RTN","VPR CAC",70,0)
  5810    Q
  5811   "RTN","VPR CAC",71,0)
  5812    ;
  5813   "RTN","VPR CAC",72,0)
  5814    ;
  5815   "RTN","VPR CAC",73,0)
  5816   BLDLIST(LI ST,VPRY) ;
  5817   "RTN","VPR CAC",74,0)
  5818    N I,CNT,N ODE
  5819   "RTN","VPR CAC",75,0)
  5820    S I=0 F   S I=$O(VPR Y(I)) Q:I' >0  D
  5821   "RTN","VPR CAC",76,0)
  5822    .S NODE=$ G(VPRY(I))  I +NODE'> 0 Q
  5823   "RTN","VPR CAC",77,0)
  5824    .;S CNT=$ O(VPRY(I), -1)+1
  5825   "RTN","VPR CAC",78,0)
  5826    .S LIST(+ $P(NODE,U) )=""
  5827   "RTN","VPR CAC",79,0)
  5828    Q
  5829   "RTN","VPR CAC",80,0)
  5830    ;
  5831   "RTN","VPR CAC",81,0)
  5832    ;The appo intment li st date ra nge is des igned to q uery for f ull dates,  
  5833   "RTN","VPR CAC",82,0)
  5834    ;so when  the search  result ex ceeds 200  appointmen ts, 
  5835   "RTN","VPR CAC",83,0)
  5836    ;the disp lay will e nd with th e last app ointment o f the last  day befor e the maxi mum was re ached. 
  5837   "RTN","VPR CAC",84,0)
  5838   CLINPTS2(Y ,USER,CLIN ,BDATE,EDA TE) ; WRAP PER FUNCTI ON FOR USE  BY RPC CA LL ORQPT C LINIC PATI ENTS
  5839   "RTN","VPR CAC",85,0)
  5840    N MAXAPPT S,APPTBGN, APPTEND,NU MAPPTS
  5841   "RTN","VPR CAC",86,0)
  5842    S MAXAPPT S=200 I BD ATE=EDATE  S MAXAPPTS =0  ; if w e only wan t one day,  don't lim it answer.
  5843   "RTN","VPR CAC",87,0)
  5844    D CLINPTS (.Y,USER,C LIN,BDATE, EDATE,MAXA PPTS,.APPT BGN,.APPTE ND)
  5845   "RTN","VPR CAC",88,0)
  5846    S NUMAPPT S=$O(Y("") ,-1)
  5847   "RTN","VPR CAC",89,0)
  5848    I MAXAPPT S,NUMAPPTS '<MAXAPPTS  D
  5849   "RTN","VPR CAC",90,0)
  5850    . N ORI
  5851   "RTN","VPR CAC",91,0)
  5852    . S ORI=0  S APPTEND =$P(APPTEN D,".")
  5853   "RTN","VPR CAC",92,0)
  5854    . F  S OR I=$O(Y(ORI )) Q:'ORI   D  ;erase  last day' s appts si nce we ass ume it to  be partial
  5855   "RTN","VPR CAC",93,0)
  5856    .. I APPT END<$P(Y(O RI),U,4) K  Y(ORI) S  NUMAPPTS=N UMAPPTS-1  ;erase an  appointmen t
  5857   "RTN","VPR CAC",94,0)
  5858    . S Y(MAX APPTS+1)=" ^ *** UNAB LE TO SHOW  ALL APPOI NTMENTS ** *"
  5859   "RTN","VPR CAC",95,0)
  5860    . S Y(MAX APPTS+2)=" ^ Showing  the first  "_NUMAPPTS _" appoint ments from  "_$$FMTE^ XLFDT(APPT BGN,"D")_"  to "_$$FM TE^XLFDT(A PPTEND-1," D")
  5861   "RTN","VPR CAC",96,0)
  5862    . S Y(MAX APPTS+3)=" ^"_$C(160) _" Modify  the appoin tment list  date rang e to start  on "_$$FM TE^XLFDT(A PPTEND,"D" )_" to see  additiona l appointm ents." ;ad d blank li ne
  5863   "RTN","VPR CAC",97,0)
  5864    . S Y(MAX APPTS+4)=" ^"_$C(160) _$C(160) ; add blank  line
  5865   "RTN","VPR CAC",98,0)
  5866    ;
  5867   "RTN","VPR CAC",99,0)
  5868   CLINPTS(Y, USER,CLIN, BDATE,EDAT E,MAXAPPTS ,APPTBGN,A PPTEND) ;  RETURN LIS T OF PTS W /CLINIC AP PT W/IN BE GINNING AN D END DATE S
  5869   "RTN","VPR CAC",100,0 )
  5870    ; PKS-8/2 003: Modif ied for ne w scheduli ng pkg API s.
  5871   "RTN","VPR CAC",101,0 )
  5872    I +$G(CLI N)<1 S Y(1 )="^No cli nic identi fied" Q 
  5873   "RTN","VPR CAC",102,0 )
  5874    I $$ACTLO C^ORWU(CLI N)'=1 S Y( 1)="^Clini c is inact ive or Occ asion Of S ervice" Q
  5875   "RTN","VPR CAC",103,0 )
  5876    N ORSRV,O RRESULT,OR ERR,ORI,OR PT,ORPTSTA T,ORAPPT,O RCLIN,SDAR RAY,NODE
  5877   "RTN","VPR CAC",104,0 )
  5878    I $L($G(M AXAPPTS))= 0 S MAXAPP TS=200
  5879   "RTN","VPR CAC",105,0 )
  5880    S ORSRV=$ G(^VA(200, USER,5)) I  +ORSRV>0  S ORSRV=$P (ORSRV,U)
  5881   "RTN","VPR CAC",106,0 )
  5882    I BDATE=" " S BDATE= $$UP^XLFST R($$GET^XP AR("USR^SR V.`"_+$G(O RSRV)_"^DI V^SYS^PKG" ,"ORLP DEF AULT CLINI C START DA TE",1,"E") )
  5883   "RTN","VPR CAC",107,0 )
  5884    I EDATE=" " S EDATE= $$UP^XLFST R($$GET^XP AR("USR^SR V.`"_+$G(O RSRV)_"^DI V^SYS^PKG" ,"ORLP DEF AULT CLINI C STOP DAT E",1,"E"))
  5885   "RTN","VPR CAC",108,0 )
  5886    ;
  5887   "RTN","VPR CAC",109,0 )
  5888    ; Convert  BDATE, ED ATE to FM  Date/Time:
  5889   "RTN","VPR CAC",110,0 )
  5890    D DT^DILF ("T",BDATE ,.BDATE,"" ,"")
  5891   "RTN","VPR CAC",111,0 )
  5892    D DT^DILF ("T",EDATE ,.EDATE,"" ,"")
  5893   "RTN","VPR CAC",112,0 )
  5894    I (BDATE= -1)!(EDATE =-1) S Y(1 )="^Error  in date ra nge." Q 
  5895   "RTN","VPR CAC",113,0 )
  5896    S EDATE=$ P(EDATE,". ")_.5 ; Ad d 1/2 day  to end dat e.
  5897   "RTN","VPR CAC",114,0 )
  5898    ;
  5899   "RTN","VPR CAC",115,0 )
  5900    K ^TMP($J ,"SDAMA301 ") ; Clean  house bef ore starti ng.
  5901   "RTN","VPR CAC",116,0 )
  5902    S ORRESUL T=""
  5903   "RTN","VPR CAC",117,0 )
  5904    S ORCLIN= +CLIN
  5905   "RTN","VPR CAC",118,0 )
  5906    S SDARRAY (1)=BDATE_ ";"_EDATE
  5907   "RTN","VPR CAC",119,0 )
  5908    S SDARRAY (2)=+CLIN
  5909   "RTN","VPR CAC",120,0 )
  5910    S SDARRAY (3)="R;I;N T"
  5911   "RTN","VPR CAC",121,0 )
  5912    S SDARRAY ("SORT")=" P" ;no cli nic index
  5913   "RTN","VPR CAC",122,0 )
  5914    S SDARRAY ("FLDS")=" 3;4"  ;App tStatus^IE N;PtName
  5915   "RTN","VPR CAC",123,0 )
  5916    I MAXAPPT S S SDARRA Y("MAX")=M AXAPPTS
  5917   "RTN","VPR CAC",124,0 )
  5918    ;
  5919   "RTN","VPR CAC",125,0 )
  5920    S ORRESUL T=$$SDAPI^ SDAMA301(. SDARRAY) ;  DBIA 4433
  5921   "RTN","VPR CAC",126,0 )
  5922    ;
  5923   "RTN","VPR CAC",127,0 )
  5924    ; Deal wi th server  errors:
  5925   "RTN","VPR CAC",128,0 )
  5926    I ORRESUL T<0 D  S Y (1)=U_ORER R Q
  5927   "RTN","VPR CAC",129,0 )
  5928    .S ORERR= ""
  5929   "RTN","VPR CAC",130,0 )
  5930    .N IDXERR  S IDXERR= $O(^TMP($J ,"SDAMA301 ","")) Q:I DXERR'>0
  5931   "RTN","VPR CAC",131,0 )
  5932    .S ORERR= ^TMP($J,"S DAMA301",I DXERR)
  5933   "RTN","VPR CAC",132,0 )
  5934    ;
  5935   "RTN","VPR CAC",133,0 )
  5936    ; Reassig n ^TMP arr ay to loca l array:
  5937   "RTN","VPR CAC",134,0 )
  5938    S (ORPT,O RI)=0
  5939   "RTN","VPR CAC",135,0 )
  5940    I ORRESUL T'>0 S Y(1 )="^No app ointments. " Q
  5941   "RTN","VPR CAC",136,0 )
  5942    F  S ORPT =$O(^TMP($ J,"SDAMA30 1",ORPT))  Q:ORPT=""   D
  5943   "RTN","VPR CAC",137,0 )
  5944    .S ORAPPT =""
  5945   "RTN","VPR CAC",138,0 )
  5946    .F  S ORA PPT=$O(^TM P($J,"SDAM A301",ORPT ,ORAPPT))  Q:ORAPPT=" "  D
  5947   "RTN","VPR CAC",139,0 )
  5948    ..S ORI=O RI+1
  5949   "RTN","VPR CAC",140,0 )
  5950    ..S NODE= ^TMP($J,"S DAMA301",O RPT,ORAPPT )
  5951   "RTN","VPR CAC",141,0 )
  5952    ..S Y(ORI )=$TR($P(N ODE,U,4)," ;","^") ;  IEN^Name.
  5953   "RTN","VPR CAC",142,0 )
  5954    ..S Y(ORI )=Y(ORI)_U _ORCLIN ;  ^Clinic IE N.
  5955   "RTN","VPR CAC",143,0 )
  5956    ..S Y(ORI )=Y(ORI)_U _ORAPPT ;  App't.
  5957   "RTN","VPR CAC",144,0 )
  5958    ..I $L($G (APPTEND)) =0 S APPTE ND=ORAPPT, APPTBGN=OR APPT
  5959   "RTN","VPR CAC",145,0 )
  5960    ..I ORAPP T>APPTEND  S APPTEND= ORAPPT
  5961   "RTN","VPR CAC",146,0 )
  5962    ..I ORAPP T<APPTBGN  S APPTBGN= ORAPPT
  5963   "RTN","VPR CAC",147,0 )
  5964    ..S ORPTS TAT=$P($P( NODE,U,3), ";",1) ;ap pt status,  will be t ransformed  to pt sta tus.
  5965   "RTN","VPR CAC",148,0 )
  5966    ..S ORPTS TAT=$S(ORP TSTAT="I": "IPT",ORPT STAT="R":" OPT",ORPTS TAT="NT":" OPT",1:"")  ; Pt Stat us.
  5967   "RTN","VPR CAC",149,0 )
  5968    ..S Y(ORI )=Y(ORI)_U _U_U_U_U_O RPTSTAT ;  Pt I or O  status (or  "NT").
  5969   "RTN","VPR CAC",150,0 )
  5970    K ^TMP($J ,"SDAMA301 ") ; Clean  house aft er finishi ng.
  5971   "RTN","VPR CAC",151,0 )
  5972    ;
  5973   "RTN","VPR CAC",152,0 )
  5974    Q
  5975   "RTN","VPR CAC",153,0 )
  5976    ;
  5977   "RTN","VPR CAC",154,0 )
  5978   COMBPTS(LI ST,USER,PT R,BDATE,ED ATE) ;
  5979   "RTN","VPR CAC",155,0 )
  5980    N FILE,MA XAPPTS,MSG ,PTR,RTN,S RC,TXT,VPR ERR,VPRY
  5981   "RTN","VPR CAC",156,0 )
  5982    ;
  5983   "RTN","VPR CAC",157,0 )
  5984    ; Do prel iminary se ttings, cl eanup, loo k for an e xisting us er record:
  5985   "RTN","VPR CAC",158,0 )
  5986    S MSG=""                                           ;  Default.
  5987   "RTN","VPR CAC",159,0 )
  5988    S MAXAPPT S=$S(BDATE =EDATE:0,1 :200)          ; If d ate range  is only on e day then  no max, o therwise 2 00
  5989   "RTN","VPR CAC",160,0 )
  5990    S RTN=$$F IND1^DIC(1 00.24,""," QX",USER," ","","VPRE RR")
  5991   "RTN","VPR CAC",161,0 )
  5992    K VPRERR
  5993   "RTN","VPR CAC",162,0 )
  5994    D CLEAN^D ILF ; Clea n up after  DB call.
  5995   "RTN","VPR CAC",163,0 )
  5996    ;
  5997   "RTN","VPR CAC",164,0 )
  5998    ; If no c ombination  record, t hen punt:
  5999   "RTN","VPR CAC",165,0 )
  6000    I +RTN<1  D
  6001   "RTN","VPR CAC",166,0 )
  6002    .S MSG="N o combinat ion entry. "
  6003   "RTN","VPR CAC",167,0 )
  6004    .Q
  6005   "RTN","VPR CAC",168,0 )
  6006    ;
  6007   "RTN","VPR CAC",169,0 )
  6008    ; Order t hrough the  user's co mbination  source ent ries:
  6009   "RTN","VPR CAC",170,0 )
  6010    S SORT="A " ; Requir ed variabl e for PTSC OMBO^ORQPT Q5.
  6011   "RTN","VPR CAC",171,0 )
  6012    S SRC=0
  6013   "RTN","VPR CAC",172,0 )
  6014    F  S SRC= $O(^OR(100 .24,RTN,.0 1,SRC)) Q: 'SRC  D
  6015   "RTN","VPR CAC",173,0 )
  6016    .K ORY                                             ;  Clean up e ach time.
  6017   "RTN","VPR CAC",174,0 )
  6018    .S TXT=""                                       ; Ini tialize.
  6019   "RTN","VPR CAC",175,0 )
  6020    .S TXT=$G (^OR(100.2 4,RTN,.01, SRC,0))  ;  Get recor d's value.
  6021   "RTN","VPR CAC",176,0 )
  6022    .;
  6023   "RTN","VPR CAC",177,0 )
  6024    .; In cas e of error , punt:
  6025   "RTN","VPR CAC",178,0 )
  6026    .I TXT=""  S MSG="Co mbination  source ent ry error."
  6027   "RTN","VPR CAC",179,0 )
  6028    .I TXT=""  Q
  6029   "RTN","VPR CAC",180,0 )
  6030    .S PTR=$P (TXT,";")                          ; Get po inter.
  6031   "RTN","VPR CAC",181,0 )
  6032    .S FILE=" ^"_$P(TXT, ";",2)                  ; Get fi le.
  6033   "RTN","VPR CAC",182,0 )
  6034    .;
  6035   "RTN","VPR CAC",183,0 )
  6036    .; Get in fo for eac h source e ntry and b uild VPRY  array acco rdingly.
  6037   "RTN","VPR CAC",184,0 )
  6038    .I FILE=" ^DIC(42,"  D  Q                       ; War ds.
  6039   "RTN","VPR CAC",185,0 )
  6040    ..D WARDP TS^ORQPTQ2 (.VPRY,PTR )
  6041   "RTN","VPR CAC",186,0 )
  6042    ..I $D(VP RY) D BLDL IST(.LIST, .VPRY)
  6043   "RTN","VPR CAC",187,0 )
  6044    .I FILE=" ^VA(200,"  D  Q                       ; Pro viders.
  6045   "RTN","VPR CAC",188,0 )
  6046    ..D PROVP TS^ORQPTQ2 (.VPRY,PTR )
  6047   "RTN","VPR CAC",189,0 )
  6048    ..I $D(VP RY) D BLDL IST(.LIST, .VPRY)
  6049   "RTN","VPR CAC",190,0 )
  6050    .I FILE=" ^DIC(45.7, " D  Q                     ; Spe cialties.
  6051   "RTN","VPR CAC",191,0 )
  6052    ..D SPECP TS^ORQPTQ2 (.VPRY,PTR )
  6053   "RTN","VPR CAC",192,0 )
  6054    ..I $D(VP RY) D BLDL IST(.LIST, .VPRY)
  6055   "RTN","VPR CAC",193,0 )
  6056    .I FILE=" ^OR(100.21 ," D  Q                    ; Tea m Lists
  6057   "RTN","VPR CAC",194,0 )
  6058    ..D TEAMP TS^ORQPTQ1 (.VPRY,PTR )
  6059   "RTN","VPR CAC",195,0 )
  6060    ..I $D(VP RY) D BLDL IST(.LIST, .VPRY)
  6061   "RTN","VPR CAC",196,0 )
  6062    .I FILE=" ^SC(" D  Q                            ; Cli nics.
  6063   "RTN","VPR CAC",197,0 )
  6064    ..N APPTB GN,APPTEND  S (APPTBG N,APPTEND) =""
  6065   "RTN","VPR CAC",198,0 )
  6066    ..D CLINP TS^ORQPTQ2 (.VPRY,PTR ,BDATE,EDA TE,MAXAPPT S,.APPTBGN ,.APPTEND)
  6067   "RTN","VPR CAC",199,0 )
  6068    ..I $D(VP RY) D BLDL IST(.LIST, .VPRY)
  6069   "RTN","VPR CAC",200,0 )
  6070    Q
  6071   "RTN","VPR CAC",201,0 )
  6072    ;
  6073   "RTN","VPR CAC",202,0 )
  6074   GETDFLST(L IST,USER)  ;
  6075   "RTN","VPR CAC",203,0 )
  6076    N API,BEG ,END,IEN,S RC,SRV,VPR SRC,VPRY,X
  6077   "RTN","VPR CAC",204,0 )
  6078    S SRV=$G( ^VA(200,US ER,5)) I + SRV>0 S SR V=$P(SRV,U )
  6079   "RTN","VPR CAC",205,0 )
  6080    S SRC=$$G ET^XPAR("U SR.`"_USER _"^SRV.`"_ +$G(SRV)," ORLP DEFAU LT LIST SO URCE",1,"Q ")
  6081   "RTN","VPR CAC",206,0 )
  6082    ;
  6083   "RTN","VPR CAC",207,0 )
  6084    I SRC="T"  S IEN=$$G ET^XPAR("U SR.`"_USER _"^SRV.`"_ +$G(SRV)," ORLP DEFAU LT TEAM",1 ,"Q") D:+$ G(IEN)>0 T EAMPTS^ORQ PTQ1(.VPRY ,IEN)
  6085   "RTN","VPR CAC",208,0 )
  6086    I SRC="W"  S IEN=$$G ET^XPAR("U SR.`"_USER _"^SRV.`"_ +$G(SRV)," ORLP DEFAU LT WARD",1 ,"Q") D:+$ G(IEN)>0 B YWARD^ORWP T(.VPRY,IE N)
  6087   "RTN","VPR CAC",209,0 )
  6088    I SRC="P"  S IEN=$$G ET^XPAR("U SR.`"_USER _"^SRV.`"_ +$G(SRV)," ORLP DEFAU LT PROVIDE R",1,"Q")  D:+$G(IEN) >0 PROVPTS ^ORQPTQ2(. VPRY,IEN)
  6089   "RTN","VPR CAC",210,0 )
  6090    I SRC="S"  S IEN=$$G ET^XPAR("U SR.`"_USER _"^SRV.`"_ +$G(SRV)," ORLP DEFAU LT SPECIAL TY",1,"Q")  D:+$G(IEN )>0 SPECPT S^ORQPTQ2( .VPRY,IEN)
  6091   "RTN","VPR CAC",211,0 )
  6092    I SRC'="C ",SRC'="M"  D BLDLIST (.LIST,.VP RY) Q
  6093   "RTN","VPR CAC",212,0 )
  6094    ;
  6095   "RTN","VPR CAC",213,0 )
  6096     I SRC="C " D  Q
  6097   "RTN","VPR CAC",214,0 )
  6098    .F X="Mon day","Tues day","Wedn esday","Th ursday","F riday","Sa turday","S unday" D
  6099   "RTN","VPR CAC",215,0 )
  6100    ..S API=" ORLP DEFAU LT CLINIC  "_$$UP^XLF STR($$DOW^ XLFDT(DT)) ,IEN=$$GET ^XPAR("USR .`"_USER_" ^SRV.`"_+$ G(SRV),API ,1,"Q") I  +$G(IEN)>0  D
  6101   "RTN","VPR CAC",216,0 )
  6102    ...S BEG= $$UP^XLFST R($$GET^XP AR("USR.`" _USER_"^SR V.`"_+$G(S RV)_"^DIV^ SYS^PKG"," ORLP DEFAU LT CLINIC  START DATE ",1,"E"))
  6103   "RTN","VPR CAC",217,0 )
  6104    ...I BEG= "T+0" S BE G=$$FMTE^X LFDT(DT,BE G)
  6105   "RTN","VPR CAC",218,0 )
  6106    ...S END= $$UP^XLFST R($$GET^XP AR("USR.`" _USER_"^SR V.`"_+$G(S RV)_"^DIV^ SYS^PKG"," ORLP DEFAU LT CLINIC  STOP DATE" ,1,"E"))
  6107   "RTN","VPR CAC",219,0 )
  6108    ...I END= "T+0" S EN D=$$FMTE^X LFDT(DT,EN D)
  6109   "RTN","VPR CAC",220,0 )
  6110    ...D CLIN PTS2(.VPRY ,USER,+$G( IEN),BEG,E ND)
  6111   "RTN","VPR CAC",221,0 )
  6112    ...D BLDL IST(.LIST, .VPRY)
  6113   "RTN","VPR CAC",222,0 )
  6114    I SRC="M"  D  Q
  6115   "RTN","VPR CAC",223,0 )
  6116    .S IEN=$D (^OR(100.2 4,USER,0))  I +$G(IEN )>0 S IEN= USER D
  6117   "RTN","VPR CAC",224,0 )
  6118    ..S BEG=$ $UP^XLFSTR ($$GET^XPA R("USR.`"_ USER_"^SRV .`"_+$G(SR V)_"^DIV^S YS^PKG","O RLP DEFAUL T CLINIC S TART DATE" ,1,"E"))
  6119   "RTN","VPR CAC",225,0 )
  6120    ..I BEG=" T+0" S BEG =$$FMTE^XL FDT(DT,BEG )
  6121   "RTN","VPR CAC",226,0 )
  6122    ..S END=$ $UP^XLFSTR ($$GET^XPA R("USR.`"_ USER_"^SRV .`"_+$G(SR V)_"^DIV^S YS^PKG","O RLP DEFAUL T CLINIC S TOP DATE", 1,"E"))
  6123   "RTN","VPR CAC",227,0 )
  6124    ..I END=" T+0" S END =$$FMTE^XL FDT(DT,END )
  6125   "RTN","VPR CAC",228,0 )
  6126    ..D COMBP TS(.LIST,U SER,+$G(IE N),BEG,END ) ; "0"= G UI RPC cal l.
  6127   "RTN","VPR CAC",229,0 )
  6128    Q
  6129   "RTN","VPR CAC",230,0 )
  6130    ;
  6131   "RTN","VPR CAC",231,0 )
  6132   REMOPT(IEN ,OPT) ;
  6133   "RTN","VPR CAC",232,0 )
  6134    Q
  6135   "RTN","VPR CAC",233,0 )
  6136    ;
  6137   "RTN","VPR CORD")
  6138   0^6^B74593 09
  6139   "RTN","VPR CORD",1,0)
  6140   VPRCORD ;S LC/AGP - O rdering Co ntroller f or VPR ; 9 /21/12 5:5 7pm
  6141   "RTN","VPR CORD",2,0)
  6142    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  6143   "RTN","VPR CORD",3,0)
  6144    ;
  6145   "RTN","VPR CORD",4,0)
  6146    ;
  6147   "RTN","VPR CORD",5,0)
  6148   RPC(VPROUT ,PARAMS) ;  Process r equest via  RPC inste ad of CSP
  6149   "RTN","VPR CORD",6,0)
  6150    N X,REQ,V PRCNT,VPRS ITE,VPRUSE R,VPRDBUG, VPRSTA
  6151   "RTN","VPR CORD",7,0)
  6152    S VPRCNT= 0
  6153   "RTN","VPR CORD",8,0)
  6154    S VPRUSER =DUZ,VPRSI TE=DUZ(2), VPRSTA=$$S TA^XUAF4(D UZ(2))
  6155   "RTN","VPR CORD",9,0)
  6156    S X="" F   S X=$O(PA RAMS(X)) Q :X=""  S R EQ(X,1)=PA RAMS(X)
  6157   "RTN","VPR CORD",10,0 )
  6158    ;
  6159   "RTN","VPR CORD",11,0 )
  6160   COMMON ; C ome here f or both CS P and RPC  Mode
  6161   "RTN","VPR CORD",12,0 )
  6162    ;
  6163   "RTN","VPR CORD",13,0 )
  6164    N CMD
  6165   "RTN","VPR CORD",14,0 )
  6166    S CMD=$G( REQ("comma nd",1))
  6167   "RTN","VPR CORD",15,0 )
  6168    ;
  6169   "RTN","VPR CORD",16,0 )
  6170    ; returns  an order  structure  for change  orders
  6171   "RTN","VPR CORD",17,0 )
  6172    ; or plac es an orde r if auto- accept QO
  6173   "RTN","VPR CORD",18,0 )
  6174    I CMD="or dering" D   G OUT
  6175   "RTN","VPR CORD",19,0 )
  6176    . D ORDER ING^VPRCOR D1(.VPROUT ,$$VAL("ui d"),$$VAL( "qoIen"),$ $VAL("pati ent"),$$VA L("locatio n"),$$VAL( "provider" ),$$VAL("o rderAction "),0,$$VAL ("snippet" ),$$VAL("n ame"))
  6177   "RTN","VPR CORD",20,0 )
  6178    ;
  6179   "RTN","VPR CORD",21,0 )
  6180    ;
  6181   "RTN","VPR CORD",22,0 )
  6182    I CMD="li stQuickOrd ers" D  G  OUT
  6183   "RTN","VPR CORD",23,0 )
  6184    . D QOL^V PRCORD1(.V PROUT,$$VA L("locatio n"),$$VAL( "provider" ),$$VAL("p anelNumber "),$$VAL(" patient"))
  6185   "RTN","VPR CORD",24,0 )
  6186    ;
  6187   "RTN","VPR CORD",25,0 )
  6188    I CMD="re newOrder"  D  G OUT
  6189   "RTN","VPR CORD",26,0 )
  6190    . D RENEW ^VPRCORD1( .VPROUT,$$ VAL("uid") ,$$VAL("pr ovider"),0 ,$$VAL("sn ippet"),$$ VAL("name" ))
  6191   "RTN","VPR CORD",27,0 )
  6192    ;
  6193   "RTN","VPR CORD",28,0 )
  6194    I CMD="dc ReasonsLis t" D  G OU T
  6195   "RTN","VPR CORD",29,0 )
  6196    . D DCLRE AS^VPRCORD 1(.VPROUT, $$VAL("uid "),$$VAL(" provider") )
  6197   "RTN","VPR CORD",30,0 )
  6198    ;
  6199   "RTN","VPR CORD",31,0 )
  6200    I CMD="di scontinue"  D  G OUT
  6201   "RTN","VPR CORD",32,0 )
  6202    . D DC^VP RCORD1(.VP ROUT,$$VAL ("uid"),$$ VAL("provi der"),$$VA L("locatio n"),$$VAL( "patient") ,$$VAL("sn ippet"),$$ VAL("name" ))
  6203   "RTN","VPR CORD",33,0 )
  6204    ;
  6205   "RTN","VPR CORD",34,0 )
  6206    I CMD="ca ncel" D  G  OUT
  6207   "RTN","VPR CORD",35,0 )
  6208    . D CANCE L^VPRCORD1 (.VPROUT,$ $VAL("uid" ))
  6209   "RTN","VPR CORD",36,0 )
  6210    ;
  6211   "RTN","VPR CORD",37,0 )
  6212    I CMD="pe rformOrder Checks" D   G OUT
  6213   "RTN","VPR CORD",38,0 )
  6214    . D ORDER ING^VPRCOR D1(.VPROUT ,$$VAL("ui d"),$$VAL( "qoIen"),$ $VAL("pati ent"),$$VA L("locatio n"),$$VAL( "provider" ),$$VAL("o rderAction "),1)
  6215   "RTN","VPR CORD",39,0 )
  6216    ;
  6217   "RTN","VPR CORD",40,0 )
  6218    I CMD="ge tSnippets"  D  G OUT
  6219   "RTN","VPR CORD",41,0 )
  6220    .D GETSNI PS^VPRCORD 1(.VPROUT, $$VAL("pat ient"),$$V AL("provid er"))
  6221   "RTN","VPR CORD",42,0 )
  6222    ;
  6223   "RTN","VPR CORD",43,0 )
  6224    I CMD="sa veOrder" D   G OUT
  6225   "RTN","VPR CORD",44,0 )
  6226    .;M ^XTMP ("AGP INFO ","PARAMS" )=PARAMS
  6227   "RTN","VPR CORD",45,0 )
  6228    .D EN^VPR CORD3(.VPR OUT,.PARAM S)
  6229   "RTN","VPR CORD",46,0 )
  6230    ;
  6231   "RTN","VPR CORD",47,0 )
  6232    I CMD="or derAction"  D  G OUT
  6233   "RTN","VPR CORD",48,0 )
  6234    .N INFO
  6235   "RTN","VPR CORD",49,0 )
  6236    .;M ^XTMP ("AGP PARA MS")=REQ
  6237   "RTN","VPR CORD",50,0 )
  6238    .D BLDINF O(.INFO)
  6239   "RTN","VPR CORD",51,0 )
  6240    .D ORDERU ID^VPRCORD 1(.VPROUT, .INFO)
  6241   "RTN","VPR CORD",52,0 )
  6242    ;
  6243   "RTN","VPR CORD",53,0 )
  6244   OUT ;
  6245   "RTN","VPR CORD",54,0 )
  6246   END ;
  6247   "RTN","VPR CORD",55,0 )
  6248    ;
  6249   "RTN","VPR CORD",56,0 )
  6250   BLDINFO(IN FO) ;
  6251   "RTN","VPR CORD",57,0 )
  6252    N X
  6253   "RTN","VPR CORD",58,0 )
  6254    S X="" F   S X=$O(RE Q(X)) Q:X= ""  D
  6255   "RTN","VPR CORD",59,0 )
  6256    .S INFO(X )=REQ(X,1)
  6257   "RTN","VPR CORD",60,0 )
  6258    Q
  6259   "RTN","VPR CORD",61,0 )
  6260    ;
  6261   "RTN","VPR CORD",62,0 )
  6262   VAL(X) ; r eturn valu e from req uest
  6263   "RTN","VPR CORD",63,0 )
  6264    Q $G(REQ( X,1))
  6265   "RTN","VPR CORD",64,0 )
  6266    ;
  6267   "RTN","VPR CORD1")
  6268   0^7^B19523 4236
  6269   "RTN","VPR CORD1",1,0 )
  6270   VPRCORD1 ;  SLC/AGP,J LC - Proce ss Order R equest fro m AVIVA Sy stem. ; 9/ 21/12 5:59 pm
  6271   "RTN","VPR CORD1",2,0 )
  6272    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  6273   "RTN","VPR CORD1",3,0 )
  6274    Q
  6275   "RTN","VPR CORD1",4,0 )
  6276    ;
  6277   "RTN","VPR CORD1",5,0 )
  6278   ADD(X,VPRV ALUE) ; Ad d a line @ NHIN@(n)=X
  6279   "RTN","VPR CORD1",6,0 )
  6280    N RESULT
  6281   "RTN","VPR CORD1",7,0 )
  6282    S RESULT( "success") ="false"
  6283   "RTN","VPR CORD1",8,0 )
  6284    S RESULT( "error")=X
  6285   "RTN","VPR CORD1",9,0 )
  6286    D ENCODE^ VPRJSON("R ESULT","VP RVALUE","V PRERR")
  6287   "RTN","VPR CORD1",10, 0)
  6288    Q
  6289   "RTN","VPR CORD1",11, 0)
  6290    ;
  6291   "RTN","VPR CORD1",12, 0)
  6292   AE(TEXT,VP RVALUE) ;
  6293   "RTN","VPR CORD1",13, 0)
  6294    ;N RESULT
  6295   "RTN","VPR CORD1",14, 0)
  6296    ;S RESULT ("success" )="false"
  6297   "RTN","VPR CORD1",15, 0)
  6298    ;S RESULT ("error")= TEXT
  6299   "RTN","VPR CORD1",16, 0)
  6300    ;D ENCODE ^VPRJSON(" RESULT","V PRVALUE"," VPRERR")
  6301   "RTN","VPR CORD1",17, 0)
  6302    N DATA,TX T
  6303   "RTN","VPR CORD1",18, 0)
  6304    S TXT(1)= TEXT
  6305   "RTN","VPR CORD1",19, 0)
  6306    D SETERRO R^VPRUTILS (.VPRVALUE ,.TXT,.TXT ,.DATA)
  6307   "RTN","VPR CORD1",20, 0)
  6308    Q
  6309   "RTN","VPR CORD1",21, 0)
  6310    ;
  6311   "RTN","VPR CORD1",22, 0)
  6312   AEM(TEXT,V PRVALUE) ;
  6313   "RTN","VPR CORD1",23, 0)
  6314    ;N NUM,RE SULT
  6315   "RTN","VPR CORD1",24, 0)
  6316    ;S RESULT ("success" )="false"
  6317   "RTN","VPR CORD1",25, 0)
  6318    ;S NUM=0  F  S NUM=$ O(TEXT(NUM )) Q:NUM'> 0  D
  6319   "RTN","VPR CORD1",26, 0)
  6320    ;.I $G(RE SULT("erro r"))="" S  RESULT("er ror")=TEXT (NUM)
  6321   "RTN","VPR CORD1",27, 0)
  6322    ;.S RESUL T("error") =RESULT("e rror")_$C( 13,10)_TEX T(NUM)
  6323   "RTN","VPR CORD1",28, 0)
  6324    ;D ENCODE ^VPRJSON(" RESULT","V PRVALUE"," VPRERR")
  6325   "RTN","VPR CORD1",29, 0)
  6326    N DATA
  6327   "RTN","VPR CORD1",30, 0)
  6328    D SETERRO R^VPRUTILS (.VPRVALUE ,.TEXT,.TE XT,.DATA)
  6329   "RTN","VPR CORD1",31, 0)
  6330    Q
  6331   "RTN","VPR CORD1",32, 0)
  6332    ;
  6333   "RTN","VPR CORD1",33, 0)
  6334   CANCEL(UID ) ;
  6335   "RTN","VPR CORD1",34, 0)
  6336    N VPRERAR R,VPRERCNT ,VPRRES,VP RISORD,VPR OIFN,VPROK ,VPRPOSS
  6337   "RTN","VPR CORD1",35, 0)
  6338    S VPRERCN T=0,VPROUT =0
  6339   "RTN","VPR CORD1",36, 0)
  6340    I UID'["o rderID" D  AE("UID do es not con tain an or der ID") G  EXIT
  6341   "RTN","VPR CORD1",37, 0)
  6342    S DFN=$P( UID,":",5) ,VPROIFN=$ P(UID,"D", 2),VPRISOR D=1
  6343   "RTN","VPR CORD1",38, 0)
  6344    G UNO
  6345   "RTN","VPR CORD1",39, 0)
  6346    Q
  6347   "RTN","VPR CORD1",40, 0)
  6348    ;
  6349   "RTN","VPR CORD1",41, 0)
  6350    ;DC(VPRVA LUE,UID,US ER,LOC,ICN ,REAS,NAME ) ;
  6351   "RTN","VPR CORD1",42, 0)
  6352   DC(VPRVALU E,DFN,ID,U SER,LOC,RE AS,NAME) ;
  6353   "RTN","VPR CORD1",43, 0)
  6354    N RESULT, VPRDIEN,VP RERCNT,VPR FILL,VPRIS ORD,VPROK, VPRRES
  6355   "RTN","VPR CORD1",44, 0)
  6356    S VPRISOR D=1
  6357   "RTN","VPR CORD1",45, 0)
  6358    ;I $$VALI DUID(UID)= 0  D AE("U ID is not  valid UID" ,.VPRVALUE ) G DCX
  6359   "RTN","VPR CORD1",46, 0)
  6360    ;S DFN=$P (UID,":",5 )
  6361   "RTN","VPR CORD1",47, 0)
  6362    S VPROIFN =ID
  6363   "RTN","VPR CORD1",48, 0)
  6364    S VPRDIEN =+$P($G(^O R(100,VPRO IFN,0)),U, 5)
  6365   "RTN","VPR CORD1",49, 0)
  6366    D FILLID^ ORWDXC(.VP RFILL,VPRD IEN)
  6367   "RTN","VPR CORD1",50, 0)
  6368    D DC^ORWD XA(.VPRRES ,VPROIFN,U SER,LOC,RE AS,0,0)
  6369   "RTN","VPR CORD1",51, 0)
  6370    ;D UNO
  6371   "RTN","VPR CORD1",52, 0)
  6372    D KILLALR T^VPRCORD2 (DFN,VPRFI LL)
  6373   "RTN","VPR CORD1",53, 0)
  6374    I $D(VPRV ALUE)>0 G  DCX
  6375   "RTN","VPR CORD1",54, 0)
  6376    S REAS="D iscontinue  "_NAME_"  "_REAS
  6377   "RTN","VPR CORD1",55, 0)
  6378    D BLDJSON ^VPRCORD2( .VPRVALUE, .RESULT,.V PRPOSS,.VP RVALUE,$G( REAS),UID)
  6379   "RTN","VPR CORD1",56, 0)
  6380   DCX ;
  6381   "RTN","VPR CORD1",57, 0)
  6382    Q
  6383   "RTN","VPR CORD1",58, 0)
  6384    ;
  6385   "RTN","VPR CORD1",59, 0)
  6386    ;D DCLREA S(.VPRVALU E,DFN,ID,O RPROV)
  6387   "RTN","VPR CORD1",60, 0)
  6388   DCLREAS(RE SULT,DFN,V PROIFN,USE R) ;
  6389   "RTN","VPR CORD1",61, 0)
  6390    N CNT,NOD E,NUM,VPRH SKEY,VPRER ARR,VPRISO RD,VPROARR Y,VPROUT,V PRRES,VPRP OSS
  6391   "RTN","VPR CORD1",62, 0)
  6392    S VPRERCN T=0,VPROUT =0,VPRISOR D=1
  6393   "RTN","VPR CORD1",63, 0)
  6394    K VPROUT  D OFCPLX^O RWDXA(.VPR OUT,VPROIF N) I $D(VP ROUT)>0 S  RESULT("co mplexOrder ")="true"
  6395   "RTN","VPR CORD1",64, 0)
  6396    K VPROUT  D DCREN^OR WDX1(.VPRO UT,VPROIFN ) I $D(VPR OUT) S RES ULT("pendi ngRenewal" )="true"
  6397   "RTN","VPR CORD1",65, 0)
  6398    K VPROUT  D DCREASON ^ORWDX2(.V PROUT) I $ D(VPROUT)  D
  6399   "RTN","VPR CORD1",66, 0)
  6400    .S CNT=1, NUM=1 F  S  CNT=$O(VP ROUT(CNT))  Q:CNT'>0   D
  6401   "RTN","VPR CORD1",67, 0)
  6402    ..S NODE= $E(VPROUT( CNT),2,$L( VPROUT(CNT )))
  6403   "RTN","VPR CORD1",68, 0)
  6404    ..S RESUL T("lists", NUM,"value ")=$P(NODE ,U,2),RESU LT("lists" ,NUM,"id") =$P(NODE,U ),NUM=NUM+ 1
  6405   "RTN","VPR CORD1",69, 0)
  6406    Q
  6407   "RTN","VPR CORD1",70, 0)
  6408    ;
  6409   "RTN","VPR CORD1",71, 0)
  6410   EN(IEN,DFN ,LOC,USER, RSPID,ORDT YPE,CHKONL Y,VARSARR, ORDIALOG,E RRARR,VPRP OSS,RESULT ,VPRVALUE)  ;
  6411   "RTN","VPR CORD1",72, 0)
  6412    N CHECKS, CNT,DEFDLF ,DLGDEF,DL GNAME,DIEN ,DRUG,EXT, FILLER,INS T,ISCLOZ,I NT,NUM
  6413   "RTN","VPR CORD1",73, 0)
  6414    N ODIEN,O RDCHKOT,OR DERCHK,SAV EARR,STR,T EMP,TEXT
  6415   "RTN","VPR CORD1",74, 0)
  6416    I ORDTYPE ="E" S DIE N=+$P($G(^ OR(100,IEN ,0)),U,5)
  6417   "RTN","VPR CORD1",75, 0)
  6418    I ORDTYPE ="Q" S DIE N=IEN
  6419   "RTN","VPR CORD1",76, 0)
  6420    S VARSARR ("DISPLAY  GROUP IEN" )=$P($G(^O RD(101.41, $$DEFDLG^O RCD(DIEN), 0)),U,5)
  6421   "RTN","VPR CORD1",77, 0)
  6422    S VARSARR ("DISPLAY  GROUP")=$P ($G(^ORD(1 01.98,VARS ARR("DISPL AY GROUP I EN"),0)),U )
  6423   "RTN","VPR CORD1",78, 0)
  6424    D FILLID^ ORWDXC(.FI LLER,DIEN)
  6425   "RTN","VPR CORD1",79, 0)
  6426    S VARSARR ("FILLER I D")=FILLER
  6427   "RTN","VPR CORD1",80, 0)
  6428    K ^TMP($J ,"ORDER CH ECKS")
  6429   "RTN","VPR CORD1",81, 0)
  6430    I $$GET^X PAR("DIV^S YS^PKG","O RK SYSTEM  ENABLE/DIS ABLE")="E"  D
  6431   "RTN","VPR CORD1",82, 0)
  6432    .D DISPLA Y^ORWDXC(. CHECKS,DUZ ,VARSARR(" FILLER ID" )) I $D(CH ECKS) D IN FO^VPRCORD 2(.CHECKS)
  6433   "RTN","VPR CORD1",83, 0)
  6434    S DLGNAME =$P($G(^OR D(101.41,D IEN,0)),U)
  6435   "RTN","VPR CORD1",84, 0)
  6436    I ORDTYPE ="Q" S DLG NAME=$P($G (^ORD(101. 41,ORDIALO G,0)),U)
  6437   "RTN","VPR CORD1",85, 0)
  6438    I DLGNAME ="" D AE(" INVALID DE FAULT DIAL OG",.VPRVA LUE) G ENX
  6439   "RTN","VPR CORD1",86, 0)
  6440    S VARSARR ("DIALOG N AME")=DLGN AME
  6441   "RTN","VPR CORD1",87, 0)
  6442    D DLGDEF^ ORWDX(.DLG DEF,DLGNAM E)
  6443   "RTN","VPR CORD1",88, 0)
  6444    ;build or der check  array,buil d dialog s tructure a nd build s ave array
  6445   "RTN","VPR CORD1",89, 0)
  6446    D BLDARRS ^VPRCORD2( .RESULT,.O RDIALOG,.V ARSARR,DFN ,LOC,.ORDE RCHK,.SAVE ARR,.VPRPO SS)
  6447   "RTN","VPR CORD1",90, 0)
  6448    D ACCEPT^ ORWDXC(.OR DCHKOT,DFN ,VARSARR(" FILLER ID" ),"",LOC,. ORDERCHK," ",0) D INF O^VPRCORD2 (.ORDCHKOT )
  6449   "RTN","VPR CORD1",91, 0)
  6450    I CHKONLY =1 Q
  6451   "RTN","VPR CORD1",92, 0)
  6452    S SAVEARR ("ORCHECK" )=0,SAVEAR R("ORTS")= 0
  6453   "RTN","VPR CORD1",93, 0)
  6454    I ORDTYPE ="Q"!(ACTI ON="C") D  SAVE(.RESU LT,DFN,USE R,LOC,VARS ARR("DIALO G NAME"),V ARSARR("DI SPLAY GROU P IEN"),DI EN,0,.SAVE ARR)
  6455   "RTN","VPR CORD1",94, 0)
  6456   ENX ;
  6457   "RTN","VPR CORD1",95, 0)
  6458    Q
  6459   "RTN","VPR CORD1",96, 0)
  6460    ;
  6461   "RTN","VPR CORD1",97, 0)
  6462   GETSNIPS(V PRVALUE,IC N,USER) ;
  6463   "RTN","VPR CORD1",98, 0)
  6464    N CNT,DFN ,RESULT
  6465   "RTN","VPR CORD1",99, 0)
  6466    I +$G(DFN )'>0 S DFN =$$GETDFN^ MPIF001(IC N)
  6467   "RTN","VPR CORD1",100 ,0)
  6468    S CNT=0 F   S CNT=$O (^XTMP("VP R SNIPPET" ,DFN,USER, DT,CNT)) Q :CNT'>0  D
  6469   "RTN","VPR CORD1",101 ,0)
  6470    .I $G(RES ULT("text" ))'="" S R ESULT=$G(R ESULT("tex t"))_$C(13 ,10)_$G(^X TMP("VPR S NIPPET",DF N,USER,DT, CNT,"text" )) Q
  6471   "RTN","VPR CORD1",102 ,0)
  6472    .S RESULT ("text")=$ G(^XTMP("V PR SNIPPET ",DFN,USER ,DT,CNT,"t ext"))
  6473   "RTN","VPR CORD1",103 ,0)
  6474    S RESULT( "success") =$S($D(RES ULT):"true ",1:"false ")
  6475   "RTN","VPR CORD1",104 ,0)
  6476    D ENCODE^ VPRJSON("R ESULT","VP RVALUE","E RROR")
  6477   "RTN","VPR CORD1",105 ,0)
  6478    Q
  6479   "RTN","VPR CORD1",106 ,0)
  6480    ;
  6481   "RTN","VPR CORD1",107 ,0)
  6482   GETEXT(NAM E,VALUE) ;
  6483   "RTN","VPR CORD1",108 ,0)
  6484    N RESULT
  6485   "RTN","VPR CORD1",109 ,0)
  6486    I NAME="O RDERABLE"  Q $P(^ORD( 101.43,VAL UE,0),U)
  6487   "RTN","VPR CORD1",110 ,0)
  6488    I NAME="U RGENCY" Q  $P(^ORD(10 1.42,VALUE ,0),U)
  6489   "RTN","VPR CORD1",111 ,0)
  6490    I NAME="R OUTE" Q $$ GET1^DIQ(5 1.2,+VALUE _",",.01)
  6491   "RTN","VPR CORD1",112 ,0)
  6492    I NAME="D RUG" Q $$G ET1^DIQ(50 ,+VALUE_", ",.01)
  6493   "RTN","VPR CORD1",113 ,0)
  6494    Q VALUE
  6495   "RTN","VPR CORD1",114 ,0)
  6496    ;
  6497   "RTN","VPR CORD1",115 ,0)
  6498    ;entry po int for RP C for QO a nd editing  an existi ng order
  6499   "RTN","VPR CORD1",116 ,0)
  6500    ;ORDERING (.OUT,"",1 5833,10103 ,240,1089, "",1,"")
  6501   "RTN","VPR CORD1",117 ,0)
  6502   ORDERING(V PRVALUE,UI D,QIEN,ICN ,LOC,USER, ACTION,CHK ONLY,REAS, NAME,VPRPO SS) ;
  6503   "RTN","VPR CORD1",118 ,0)
  6504    N DFN,FAI L,ORDTYPE, RESULT,TEM P,VPRERCNT ,VPRISORD, VPROIFN
  6505   "RTN","VPR CORD1",119 ,0)
  6506    N VARSARR ,VPRERARR, VPRRES,VPR BLT
  6507   "RTN","VPR CORD1",120 ,0)
  6508    S VPRBLT= 0
  6509   "RTN","VPR CORD1",121 ,0)
  6510    K ^TMP($J ,"ORDER CH ECKS")
  6511   "RTN","VPR CORD1",122 ,0)
  6512    S VPRERCN T=0,VPRISO RD=0
  6513   "RTN","VPR CORD1",123 ,0)
  6514    S FAIL=0
  6515   "RTN","VPR CORD1",124 ,0)
  6516    I $L($G(U ID))>0 D
  6517   "RTN","VPR CORD1",125 ,0)
  6518    . ;I UID' ["orderID"  D AE("UID  does not  contain an  order ID" ) S FAIL=1
  6519   "RTN","VPR CORD1",126 ,0)
  6520    . S VPROI FN=$P(UID, ":",6)
  6521   "RTN","VPR CORD1",127 ,0)
  6522    I ACTION= "R" D RENE W(UID,USER ,ICN,CHKON LY) Q:VPRB LT=1  G OR DERUNO
  6523   "RTN","VPR CORD1",128 ,0)
  6524    I FAIL=1  G EXIT
  6525   "RTN","VPR CORD1",129 ,0)
  6526    I +$G(DFN )'>0 S DFN =$$GETDFN^ MPIF001(IC N) I DFN'> 0 D AE("Ca nnot find  patient df n from ICN ") G EXIT
  6527   "RTN","VPR CORD1",130 ,0)
  6528    ;I QIEN>0  S VPROIFN =QIEN
  6529   "RTN","VPR CORD1",131 ,0)
  6530    I QIEN>0  D QOSET(QI EN,ACTION, DFN,CHKONL Y,.RESULT, .VPRVALUE)
  6531   "RTN","VPR CORD1",132 ,0)
  6532    I +QIEN=0  D PROCESS (VPROIFN,A CTION,CHKO NLY,.RESUL T,.VPRVALU E)
  6533   "RTN","VPR CORD1",133 ,0)
  6534    I CHKONLY =1 Q
  6535   "RTN","VPR CORD1",134 ,0)
  6536    S TEMP=RE AS
  6537   "RTN","VPR CORD1",135 ,0)
  6538    I QIEN>0  D
  6539   "RTN","VPR CORD1",136 ,0)
  6540    .S NAME=" quick orde r "_$P($G( ^ORD(101.4 1,QIEN,0)) ,U,2)
  6541   "RTN","VPR CORD1",137 ,0)
  6542    .S REAS=" Place "_"q o"_" "_TEM P
  6543   "RTN","VPR CORD1",138 ,0)
  6544    I ACTION= "C" S REAS ="Copy "_N AME_" "_TE MP
  6545   "RTN","VPR CORD1",139 ,0)
  6546   ORDERUNO ;
  6547   "RTN","VPR CORD1",140 ,0)
  6548    Q
  6549   "RTN","VPR CORD1",141 ,0)
  6550    ;
  6551   "RTN","VPR CORD1",142 ,0)
  6552   QOSET(QIEN ,ACTION,DF N,CHKONLY, RESULT,VPR VALUE) ;
  6553   "RTN","VPR CORD1",143 ,0)
  6554    N NUM,VPR OIFN
  6555   "RTN","VPR CORD1",144 ,0)
  6556    I $P($G(^ ORD(101.41 ,QIEN,0)), U,4)'="O"  S VPROIFN= QIEN D PRO CESS(VPROI FN,ACTION, CHKONLY,.R ESULT,.VPR VALUE) Q
  6557   "RTN","VPR CORD1",145 ,0)
  6558    S NUM=0 F   S NUM=$O (^ORD(101. 41,QIEN,10 ,NUM)) Q:N UM'>0  D
  6559   "RTN","VPR CORD1",146 ,0)
  6560    .S VPROIF N=$P($G(^O RD(101.41, QIEN,10,NU M,0)),U,2)  I +$G(VPR OIFN)'>0 Q
  6561   "RTN","VPR CORD1",147 ,0)
  6562    .D PROCES S(VPROIFN, ACTION,CHK ONLY,.RESU LT,.VPRVAL UE)
  6563   "RTN","VPR CORD1",148 ,0)
  6564    Q
  6565   "RTN","VPR CORD1",149 ,0)
  6566   PROCESS(VP ROIFN,ACTI ON,CHKONLY ,RESULT,VP RVALUE,VPR OK) ;
  6567   "RTN","VPR CORD1",150 ,0)
  6568    N BLDRES, ORCAT,ORDA RR,ORDIALO G,RSPID,TE MP,TEXT
  6569   "RTN","VPR CORD1",151 ,0)
  6570    S TEMP=$G (ACTION)_V PROIFN
  6571   "RTN","VPR CORD1",152 ,0)
  6572    I $$BEG^V PRCORD2(DF N,LOC,TEMP ,USER,.VAR SARR,.BLDR ES)=0 G PR OCESSX
  6573   "RTN","VPR CORD1",153 ,0)
  6574    I $P(BLDR ES(0),U,4) ="Q" D
  6575   "RTN","VPR CORD1",154 ,0)
  6576    .S ORDTYP E="Q"
  6577   "RTN","VPR CORD1",155 ,0)
  6578    .I $P(BLD RES(0),U)' =1,$P(BLDR ES(0),U)'= 2 D AE("Qu ick Order  is not set  to Auto-A ccept",.VP RVALUE) G  PROCESSX
  6579   "RTN","VPR CORD1",156 ,0)
  6580    I $G(ORDT YPE)="" S  ORDTYPE=$S (ACTION="C ":"E",ACTI ON="X":"E" ,1:"N")
  6581   "RTN","VPR CORD1",157 ,0)
  6582    S RSPID=$ P(BLDRES(0 ),U,2)
  6583   "RTN","VPR CORD1",158 ,0)
  6584    I ACTION= "X" I $$CH ANGE^VPRCO RD2(VPROIF N,DFN,LOC, USER,.ERRA RR,.VPRVAL UE)=0 G PR OCESSX
  6585   "RTN","VPR CORD1",159 ,0)
  6586    I ORDTYPE ="Q" D
  6587   "RTN","VPR CORD1",160 ,0)
  6588    .D GETQDL G^ORCD(VPR OIFN)
  6589   "RTN","VPR CORD1",161 ,0)
  6590    .S ORCAT= $S(+$G(^DP T(DFN,.1)) >0:"I",1:" O"),PROMPT =$$PTR("SI G")
  6591   "RTN","VPR CORD1",162 ,0)
  6592    .D SIG^OR CDPS2
  6593   "RTN","VPR CORD1",163 ,0)
  6594    I '$D(ORD IALOG) D
  6595   "RTN","VPR CORD1",164 ,0)
  6596    .S ORDIAL OG=+$P($G( ^OR(100,+V PROIFN,0)) ,U,5)
  6597   "RTN","VPR CORD1",165 ,0)
  6598    .D GETDLG 1^ORCD(ORD IALOG)
  6599   "RTN","VPR CORD1",166 ,0)
  6600    .D GETORD ER^ORCD(+V PROIFN)
  6601   "RTN","VPR CORD1",167 ,0)
  6602    D EN(+VPR OIFN,DFN,L OC,USER,RS PID,ORDTYP E,CHKONLY, .VARSARR,. ORDIALOG,. ERRARR,.VP RPOSS,.RES ULT,.VPRVA LUE)
  6603   "RTN","VPR CORD1",168 ,0)
  6604   PROCESSX ;
  6605   "RTN","VPR CORD1",169 ,0)
  6606    Q
  6607   "RTN","VPR CORD1",170 ,0)
  6608    ;
  6609   "RTN","VPR CORD1",171 ,0)
  6610   QOL(RESULT ,LOC,PROV, IEN) ;
  6611   "RTN","VPR CORD1",172 ,0)
  6612    N CNT,BLD RES,DIEN,N AME,NODE,N UM,TEXT,TY PE,VARSARR ,VPRERCNT, VPRERARR,V PROARRY,VP RPOSS
  6613   "RTN","VPR CORD1",173 ,0)
  6614    S VPRERCN T=0
  6615   "RTN","VPR CORD1",174 ,0)
  6616    S DIEN="" ,NUM=0,TEX T=""
  6617   "RTN","VPR CORD1",175 ,0)
  6618    F  S NUM= $O(^VPRPAN EL(IEN,"OR DER DIALOG S",NUM)) Q :NUM'>0  D
  6619   "RTN","VPR CORD1",176 ,0)
  6620    .S DIEN=$ G(^VPRPANE L(IEN,"ORD ER DIALOGS ",NUM,0))  Q:+DIEN'>0
  6621   "RTN","VPR CORD1",177 ,0)
  6622    .S NAME=$ P($G(^ORD( 101.41,+DI EN,0)),U)  I NAME=""  Q
  6623   "RTN","VPR CORD1",178 ,0)
  6624    .I $$BEG^ VPRCORD2(D FN,LOC,DIE N,PROV,.VA RSARR,.BLD RES)=0 G Q OLX
  6625   "RTN","VPR CORD1",179 ,0)
  6626    .S TYPE=$ P(BLDRES(0 ),U,4)
  6627   "RTN","VPR CORD1",180 ,0)
  6628    .S RESULT ("qo",NUM, "name")=NA ME,RESULT( "qo",NUM," id")=DIEN, RESULT("qo ",NUM,"typ e")=TYPE
  6629   "RTN","VPR CORD1",181 ,0)
  6630    I $D(VPRV ALUE)>0 G  QOLX
  6631   "RTN","VPR CORD1",182 ,0)
  6632   QOLX ;
  6633   "RTN","VPR CORD1",183 ,0)
  6634    Q
  6635   "RTN","VPR CORD1",184 ,0)
  6636    ;
  6637   "RTN","VPR CORD1",185 ,0)
  6638   RENEW(VPRV ALUE,DFN,I D,ORPROV,C HKONLY,REA S,NAME,LOC ) ;
  6639   "RTN","VPR CORD1",186 ,0)
  6640    ;RENEW(VP RVALUE,UID ,PROVP,CHK ONLY,REAS, NAME) ;
  6641   "RTN","VPR CORD1",187 ,0)
  6642    ;Input -  DFN of the  patient
  6643   "RTN","VPR CORD1",188 ,0)
  6644    ;         RX to be r enewed
  6645   "RTN","VPR CORD1",189 ,0)
  6646    ;
  6647   "RTN","VPR CORD1",190 ,0)
  6648    N X,ORY,O RPKG,ORITM ,PSOSTAT,A ,PDET,ORFL DS,DRUG,DI SPLAY,FAIL ,LIST,OCHK S,OCO,OCLI ST,ORCPLX, ORINFO,ORP VSTS
  6649   "RTN","VPR CORD1",191 ,0)
  6650    N ORL,PCP ,PCPN,RESU LT,RNWFLDS ,SPACES,Y, ORUSR,NEWI FN,PNM,RXE ,VPROIFN
  6651   "RTN","VPR CORD1",192 ,0)
  6652    N VPRERAR R,VPRERCNT ,VPRRES,VP RISORD,VPR OK
  6653   "RTN","VPR CORD1",193 ,0)
  6654    K ^TMP($J ,"ORDER CH ECKS")
  6655   "RTN","VPR CORD1",194 ,0)
  6656    S VPRERCN T=0,VPRISO RD=1
  6657   "RTN","VPR CORD1",195 ,0)
  6658    S VPROIFN =ID
  6659   "RTN","VPR CORD1",196 ,0)
  6660    D RNWFLDS ^ORWDXR(.R NWFLDS,VPR OIFN) S OR FLDS(1)=RN WFLDS(0)
  6661   "RTN","VPR CORD1",197 ,0)
  6662    D ISCPLX^ ORWDXR(.OR CPLX,VPROI FN) S ORCP LX=+$G(ORC PLX)
  6663   "RTN","VPR CORD1",198 ,0)
  6664    I CHKONLY =1 Q
  6665   "RTN","VPR CORD1",199 ,0)
  6666    D RENEW^O RWDXR(.RES ULT,VPROIF N,DFN,ORPR OV,LOC,.OR FLDS,ORCPL X,0)
  6667   "RTN","VPR CORD1",200 ,0)
  6668    S NEWIFN= $P(^OR(100 ,VPROIFN,3 ),"^",6)
  6669   "RTN","VPR CORD1",201 ,0)
  6670    S $P(^OR( 100,NEWIFN ,8,1,0),"^ ",13)=ORPR OV
  6671   "RTN","VPR CORD1",202 ,0)
  6672    I $D(VPRV ALUE)>0 G  RENEWX
  6673   "RTN","VPR CORD1",203 ,0)
  6674    S REAS="R enew "_NAM E_" "_REAS
  6675   "RTN","VPR CORD1",204 ,0)
  6676   RENEWUNO ;
  6677   "RTN","VPR CORD1",205 ,0)
  6678    ;I VPRISO RD=1 D UNL KORD^ORWDX (.VPROK,VP ROIFN) I ' VPROK D AE ("Order un lock Faile d") K VPRO K
  6679   "RTN","VPR CORD1",206 ,0)
  6680   RENEWUNL ;
  6681   "RTN","VPR CORD1",207 ,0)
  6682    ;D UNLOCK ^ORWDX(.VP ROK,DFN) I  'VPROK D  AE("Chart  unlock Fai led")
  6683   "RTN","VPR CORD1",208 ,0)
  6684   RENEWX ;
  6685   "RTN","VPR CORD1",209 ,0)
  6686    ;D ENCODE ^VPRJSON(" RESULT","V PRVALUE"," VPRERR")
  6687   "RTN","VPR CORD1",210 ,0)
  6688    Q
  6689   "RTN","VPR CORD1",211 ,0)
  6690    ;
  6691   "RTN","VPR CORD1",212 ,0)
  6692   PTR(NAME)  ; -- Retur ns ptr val ue of prom pt in Dial og file
  6693   "RTN","VPR CORD1",213 ,0)
  6694    Q +$O(^OR D(101.41," AB",$E("OR  GTX "_NAM E,1,63),0) )
  6695   "RTN","VPR CORD1",214 ,0)
  6696    ;
  6697   "RTN","VPR CORD1",215 ,0)
  6698   SAVE(VPRRE S,DFN,USER ,LOC,DLGNA ME,DGIEN,Q OIEN,ORIFN ,SAVEARR)  ;
  6699   "RTN","VPR CORD1",216 ,0)
  6700    N CNT,NUM ,VPROREST
  6701   "RTN","VPR CORD1",217 ,0)
  6702    I QOIEN>0  D SAVE^OR WDX(.VPROR EST,DFN,US ER,LOC,DLG NAME,DGIEN ,QOIEN,"", .SAVEARR," ",DT,"",0)
  6703   "RTN","VPR CORD1",218 ,0)
  6704    I ORIFN>0  D SAVE^OR WDX(.VPROR EST,DFN,US ER,LOC,DLG NAME,DGIEN ,"",ORIFN, .SAVEARR," ",DT,"C",0 )
  6705   "RTN","VPR CORD1",219 ,0)
  6706    S CNT=$O( VPRRES("") ,-1)
  6707   "RTN","VPR CORD1",220 ,0)
  6708    S NUM=0 F   S NUM=$O (VPROREST( NUM)) Q:NU M'>0  D
  6709   "RTN","VPR CORD1",221 ,0)
  6710    .S CNT=CN T+1,VPRRES ("resultTe xt")=$G(VP RRES("resu ltText"))_ $C(13,10)_ VPROREST(N UM)
  6711   "RTN","VPR CORD1",222 ,0)
  6712    Q
  6713   "RTN","VPR CORD1",223 ,0)
  6714    ;
  6715   "RTN","VPR CORD1",224 ,0)
  6716   UNO ;
  6717   "RTN","VPR CORD1",225 ,0)
  6718    ;I VPRISO RD=1 D UNL KORD^ORWDX (.VPROK,VP ROIFN) I ' VPROK D AE ("Order un lock Faile d") K VPRO K
  6719   "RTN","VPR CORD1",226 ,0)
  6720   UNLOCK ;
  6721   "RTN","VPR CORD1",227 ,0)
  6722    ;D UNLOCK ^ORWDX(.VP ROK,DFN) I  'VPROK D  AE("Chart  unlock Fai led")
  6723   "RTN","VPR CORD1",228 ,0)
  6724   EXIT ;
  6725   "RTN","VPR CORD1",229 ,0)
  6726    S VPRBLT= 1
  6727   "RTN","VPR CORD1",230 ,0)
  6728    ;D BLDXML D^VPRCORD2 (.VPRERARR ,.VPRRES,. VPRPOSS)
  6729   "RTN","VPR CORD1",231 ,0)
  6730    K ^TMP($J ,"ORDER CH ECKS")
  6731   "RTN","VPR CORD1",232 ,0)
  6732    Q
  6733   "RTN","VPR CORD1",233 ,0)
  6734    ;
  6735   "RTN","VPR CORD1",234 ,0)
  6736   VAL(REQ,X)  ; return  value from  request
  6737   "RTN","VPR CORD1",235 ,0)
  6738    Q $G(REQ( X,1))
  6739   "RTN","VPR CORD1",236 ,0)
  6740    ;
  6741   "RTN","VPR CORD1",237 ,0)
  6742   VALIDUID(U ID) ;
  6743   "RTN","VPR CORD1",238 ,0)
  6744    I UID["me d" Q 1
  6745   "RTN","VPR CORD1",239 ,0)
  6746    Q 0
  6747   "RTN","VPR CORD1",240 ,0)
  6748    ;
  6749   "RTN","VPR CORD1",241 ,0)
  6750   PRECHK(VPR OK,DFN,LOC ,VPROIFN,O RPROV,ACTI ON,PACTION ,VARSARR,S AVEARR,VPR OARRY,ERRO R) ;
  6751   "RTN","VPR CORD1",242 ,0)
  6752    N ORDERCH K,ORDTYPE, TEMP,VPRPK G
  6753   "RTN","VPR CORD1",243 ,0)
  6754    I PACTION '="N" D GE TPKG^ORWDX R(.VPRPKG, VPROIFN) I  '$D(VPRPK G) D AE("I nvalid Ord er Number" ,.ERROR) S  VPROK=2 Q
  6755   "RTN","VPR CORD1",244 ,0)
  6756    I VPRPKG[ "PS" D  I  VPROK>0 Q
  6757   "RTN","VPR CORD1",245 ,0)
  6758    .S ORDTYP E=$S(ACTIO N="R":"E", PACTION="C ":"E",PACT ION="X":"E ",PACTION= "N":"N",1: "Q")
  6759   "RTN","VPR CORD1",246 ,0)
  6760    .D ALLWOR D^ORALWORD (.VPROK,DF N,VPROIFN, ORDTYPE,OR PROV) I $G (VPROK)>0  D AEM(.VPR OK,.ERROR)  Q
  6761   "RTN","VPR CORD1",247 ,0)
  6762    .I ACTION ="DL"!(ACT ION="RENEW ") D  I VP ROK>0 Q
  6763   "RTN","VPR CORD1",248 ,0)
  6764    .. S ORTY PE=$S(ACTI ON="DL":"D C",ACTION= "RENEW":"R N",1:"") I  ORTYPE=""  Q
  6765   "RTN","VPR CORD1",249 ,0)
  6766    .. D VALI D^ORWDXA(. VPROK,VPRO IFN,ORTYPE ,ORPROV) I  $G(VPROK) '="" D AE( VPROK,.ERR OR) S VPRO K=2 Q
  6767   "RTN","VPR CORD1",250 ,0)
  6768    ..I ACTIO N="DL" Q
  6769   "RTN","VPR CORD1",251 ,0)
  6770    ..D GTORI TM^ORWDXR( .ORITM,VPR OIFN)
  6771   "RTN","VPR CORD1",252 ,0)
  6772    ..I VPRPK G="PSO" D  FAILDEA^OR WDPS1(.FAI L,ORITM,OR PROV,"O")  I FAIL D A E("Failed  DEA Check" ,.ERROR) S  VPROK=2 Q
  6773   "RTN","VPR CORD1",253 ,0)
  6774    ..D RNWFL DS^ORWDXR( .RNWFLDS,V PROIFN) S  ORFLDS(1)= RNWFLDS(0)
  6775   "RTN","VPR CORD1",254 ,0)
  6776    ..D CHKGR P^ORWDPS2( .DISPLAY,V PROIFN) ;I  DISPLAY'= 2 D AE("Pa ckage Prob lem on Ord er") G UNO
  6777   "RTN","VPR CORD1",255 ,0)
  6778    ;
  6779   "RTN","VPR CORD1",256 ,0)
  6780    I ACTION= "P" D  I V PROK>0 Q 
  6781   "RTN","VPR CORD1",257 ,0)
  6782    .D BLDPOR D(VPROIFN, DFN,LOC,PA CTION,ORPR OV,.VARSAR R,.VPROK,. VPROARRY,. ORDERCHK,. SAVEARR)
  6783   "RTN","VPR CORD1",258 ,0)
  6784    ;
  6785   "RTN","VPR CORD1",259 ,0)
  6786    W !,VPRPK G
  6787   "RTN","VPR CORD1",260 ,0)
  6788    W !,VPROI FN
  6789   "RTN","VPR CORD1",261 ,0)
  6790    D PEROC(. VPROK,DFN, VPROIFN,VP RPKG,ACTIO N,LOC,.ORD ERCHK,.VAR SARR,.ORDI ALOG,.SAVE ARR,.VPROA RRY)
  6791   "RTN","VPR CORD1",262 ,0)
  6792    Q
  6793   "RTN","VPR CORD1",263 ,0)
  6794    ;
  6795   "RTN","VPR CORD1",264 ,0)
  6796   BLDPORD(VP ROIFN,DFN, LOC,PACTIO N,ORPROV,V ARSARR,VPR OK,ORDIALO G,ORDERCHK ,SAVEARR,E RROR) ;
  6797   "RTN","VPR CORD1",265 ,0)
  6798    N BLDRES, DIEN,ORDTY PE,TEMP
  6799   "RTN","VPR CORD1",266 ,0)
  6800    S TEMP=$G (PACTION)_ VPROIFN
  6801   "RTN","VPR CORD1",267 ,0)
  6802    I $$BEG^V PRCORD2(DF N,LOC,TEMP ,ORPROV,.V ARSARR,.BL DRES)=0 S  VPROK=2 Q
  6803   "RTN","VPR CORD1",268 ,0)
  6804    I $P(BLDR ES(0),U,4) ="Q" D
  6805   "RTN","VPR CORD1",269 ,0)
  6806    .S ORDTYP E="Q"
  6807   "RTN","VPR CORD1",270 ,0)
  6808    .I $P(BLD RES(0),U)' =1,$P(BLDR ES(0),U)'= 2 D AE("Qu ick Order  is not set  to Auto-A ccept",.VP RVALUE) S  VPROK=2 Q
  6809   "RTN","VPR CORD1",271 ,0)
  6810    I $G(ORDT YPE)="" S  ORDTYPE=$S (PACTION=" C":"E",PAC TION="X":" E",1:"N")
  6811   "RTN","VPR CORD1",272 ,0)
  6812    S RSPID=$ P(BLDRES(0 ),U,2)
  6813   "RTN","VPR CORD1",273 ,0)
  6814    I PACTION ="X" I $$C HANGE^VPRC ORD2(VPROI FN,DFN,LOC ,USER,.ERR ARR,.VPRVA LUE)=0 G P ROCESSX
  6815   "RTN","VPR CORD1",274 ,0)
  6816    S VARSARR ("DISPLAY  GROUP IEN" )=$S(ORDTY PE="Q":$P( $G(^ORD(10 1.41,$$DEF DLG^ORCD(V PROIFN),0) ),U,5),1:+ $P(^OR(100 ,VPROIFN,0 ),U,11))
  6817   "RTN","VPR CORD1",275 ,0)
  6818    S VARSARR ("DISPLAY  GROUP")=$P ($G(^ORD(1 01.98,VARS ARR("DISPL AY GROUP I EN"),0)),U )
  6819   "RTN","VPR CORD1",276 ,0)
  6820    D BLDORDL G(.ORDIALO G,VPROIFN, DFN,RSPID, ORDTYPE)
  6821   "RTN","VPR CORD1",277 ,0)
  6822    S DIEN=VA RSARR("DIS PLAY GROUP  IEN")
  6823   "RTN","VPR CORD1",278 ,0)
  6824    D FILLID^ ORWDXC(.FI LLER,DIEN)
  6825   "RTN","VPR CORD1",279 ,0)
  6826    S VARSARR ("FILLER I D")=FILLER
  6827   "RTN","VPR CORD1",280 ,0)
  6828    I ORDTYPE ="E" S DIE N=+$P($G(^ OR(100,VPR OIFN,0)),U ,5)
  6829   "RTN","VPR CORD1",281 ,0)
  6830    I ORDTYPE ="Q" S DIE N=VPROIFN
  6831   "RTN","VPR CORD1",282 ,0)
  6832    S DLGNAME =$P($G(^OR D(101.41,D IEN,0)),U)
  6833   "RTN","VPR CORD1",283 ,0)
  6834    I DLGNAME ="" D AE(" INVALID DE FAULT DIAL OG",.ERROR ) S VPROK= 2 Q
  6835   "RTN","VPR CORD1",284 ,0)
  6836    S VARSARR ("DIALOG N AME")=DLGN AME
  6837   "RTN","VPR CORD1",285 ,0)
  6838    D DLGDEF^ ORWDX(.DLG DEF,DLGNAM E)
  6839   "RTN","VPR CORD1",286 ,0)
  6840    ;build or der check  array,buil d dialog s tructure a nd build s ave array
  6841   "RTN","VPR CORD1",287 ,0)
  6842    D BLDARRS ^VPRCORD2( .RESULT,.O RDIALOG,.V ARSARR,DFN ,LOC,.ORDE RCHK,.SAVE ARR,.VPRPO SS)
  6843   "RTN","VPR CORD1",288 ,0)
  6844    Q
  6845   "RTN","VPR CORD1",289 ,0)
  6846    ;
  6847   "RTN","VPR CORD1",290 ,0)
  6848   BLDORDLG(O RDIALOG,VP ROIFN,DFN, RSPID,ORDT YPE) ;
  6849   "RTN","VPR CORD1",291 ,0)
  6850    N PROMPT
  6851   "RTN","VPR CORD1",292 ,0)
  6852    I ORDTYPE ="Q" D
  6853   "RTN","VPR CORD1",293 ,0)
  6854    .D GETQDL G^ORCD(VPR OIFN)
  6855   "RTN","VPR CORD1",294 ,0)
  6856    .S ORCAT= $S(+$G(^DP T(DFN,.1)) >0:"I",1:" O"),PROMPT =$$PTR("SI G")
  6857   "RTN","VPR CORD1",295 ,0)
  6858    .D SIG^OR CDPS2
  6859   "RTN","VPR CORD1",296 ,0)
  6860    I '$D(ORD IALOG) D
  6861   "RTN","VPR CORD1",297 ,0)
  6862    .S ORDIAL OG=+$P($G( ^OR(100,+V PROIFN,0)) ,U,5)
  6863   "RTN","VPR CORD1",298 ,0)
  6864    .D GETDLG 1^ORCD(ORD IALOG)
  6865   "RTN","VPR CORD1",299 ,0)
  6866    .D GETORD ER^ORCD(+V PROIFN)
  6867   "RTN","VPR CORD1",300 ,0)
  6868    Q
  6869   "RTN","VPR CORD1",301 ,0)
  6870    ;
  6871   "RTN","VPR CORD1",302 ,0)
  6872    ;PEROC(.V PROK,DFN,V PROIFN,VPR PKG,ACTION )
  6873   "RTN","VPR CORD1",303 ,0)
  6874   PEROC(VPRO K,DFN,VPRO IFN,VPRPKG ,ACTION,LO C,ORDERCHK ,VARSARR,O RDIALOG,SA VEARR,VPRO ARRY) ;
  6875   "RTN","VPR CORD1",304 ,0)
  6876    N A,OCO,O CLIST,ORIN FO,ORL,OCH KS,PATTYPE ,VPRREN,VP RPOSS
  6877   "RTN","VPR CORD1",305 ,0)
  6878    W !,VPRPK G
  6879   "RTN","VPR CORD1",306 ,0)
  6880    W !,VPROI FN
  6881   "RTN","VPR CORD1",307 ,0)
  6882    S PATTYPE =$S(+$G(^D PT(DFN,.1) )>0:"I",1: "O")
  6883   "RTN","VPR CORD1",308 ,0)
  6884    D ON^ORWD XC(.OCO)
  6885   "RTN","VPR CORD1",309 ,0)
  6886    D DISPLAY ^ORWDXC(.O CLIST,DFN, VPRPKG) I  $D(OCLIST)  D INFO^VP RCORD2(.OC LIST)
  6887   "RTN","VPR CORD1",310 ,0)
  6888    S VPRREN= 0
  6889   "RTN","VPR CORD1",311 ,0)
  6890    I ACTION= "RENEW" D   I VPROK>0  Q
  6891   "RTN","VPR CORD1",312 ,0)
  6892    .D OXDATA ^ORWDXR01( .ORINFO,VP ROIFN)
  6893   "RTN","VPR CORD1",313 ,0)
  6894    .S A=$G(^ OR(100,VPR OIFN,0)) I  A="" D AE ("Order mi ssing from  ORDERS fi le",.VPRVA LUE) S VPR OK=2 Q
  6895   "RTN","VPR CORD1",314 ,0)
  6896    .S ORPROV =+$P(A,"^" ,4),ORL=+$ P(A,"^",10 )
  6897   "RTN","VPR CORD1",315 ,0)
  6898    .S VPRREN =1
  6899   "RTN","VPR CORD1",316 ,0)
  6900    D ACCEPT^ ORWDXC(.OC HKS,DFN,VP RPKG,PATTY PE,LOC,.OR DERCHK,VPR OIFN,VPRRE N) I $D(OC HKS) D INF O^VPRCORD2 (.OCHKS)
  6901   "RTN","VPR CORD1",317 ,0)
  6902    Q
  6903   "RTN","VPR CORD1",318 ,0)
  6904    ;
  6905   "RTN","VPR CORD1",319 ,0)
  6906   ORDERUID(V PRVALUE,IN FO) ;
  6907   "RTN","VPR CORD1",320 ,0)
  6908   ENORDER ;
  6909   "RTN","VPR CORD1",321 ,0)
  6910    N ACTION, CHKONLY,DF N,ERROR,ID ,ISQO,LOC, NAME,ORDIA LOG,ORPROV ,PACTION,P ATIENT,RES ULT,SAVEAR R,SNIPPET, TEMP,TYPE, UID,USER,V PROARRY,VP ROK,VPRPOS S
  6911   "RTN","VPR CORD1",322 ,0)
  6912    S UID=$G( INFO("uid" )),DFN=""
  6913   "RTN","VPR CORD1",323 ,0)
  6914    S ACTION= $G(INFO("a ction")),S NIPPET=$G( INFO("snip pet")),ORP ROV=$G(INF O("user")) ,PATIENT=$ G(INFO("pa tient")),N AME=$G(INF O("name"))
  6915   "RTN","VPR CORD1",324 ,0)
  6916    S LOC=$G( INFO("loca tion")),CH KONLY=$G(I NFO("order ChecksOnly ")),ISQO=$ G(INFO("is QO")),PACT ION=$G(INF O("orderAc tion")),ID =$G(INFO(" qoListId") )
  6917   "RTN","VPR CORD1",325 ,0)
  6918    S ID=$G(I NFO("qoId" ))
  6919   "RTN","VPR CORD1",326 ,0)
  6920    S TEMP=$S (PACTION=" RENEW":"Or der can be  renew to  new order. ",PACTION= "C":"Order  cannot be  renew it  can be cop y to a new  order.",1 :"")
  6921   "RTN","VPR CORD1",327 ,0)
  6922    S VPROK=0
  6923   "RTN","VPR CORD1",328 ,0)
  6924    I PACTION '="" D  I  VPROK>0 G  ORDERX
  6925   "RTN","VPR CORD1",329 ,0)
  6926    .I $$VALI DUID(UID)= 0  D AE("U ID is not  valid UID" ,.ERROR)
  6927   "RTN","VPR CORD1",330 ,0)
  6928    .S DFN=$P (UID,":",5 )
  6929   "RTN","VPR CORD1",331 ,0)
  6930    .S ID=$P( UID,":",6)
  6931   "RTN","VPR CORD1",332 ,0)
  6932    I DFN=""  S DFN=PATI ENT
  6933   "RTN","VPR CORD1",333 ,0)
  6934    ;perform  Inital Che cks
  6935   "RTN","VPR CORD1",334 ,0)
  6936    I PACTION '="" D PRE CHK(.VPROK ,LOC,DFN,I D,ORPROV,A CTION,PACT ION,.VARSA RR,.SAVEAR R,.VPROARR Y,.ERROR)
  6937   "RTN","VPR CORD1",335 ,0)
  6938    I VPROK>1 ,ACTION="R ENEW" K ^T MP($J,"ORD ER CHECKS" ) S INFO(" action")=" P",INFO("o rderAction ")="C",INF O("orderCh ecksOnly") ="true" G  ENORDER
  6939   "RTN","VPR CORD1",336 ,0)
  6940    I VPROK>1  G ORDERX
  6941   "RTN","VPR CORD1",337 ,0)
  6942    I CHKONLY ="true" S  RESULT("re sultText") =TEMP G OR DERX
  6943   "RTN","VPR CORD1",338 ,0)
  6944    ;
  6945   "RTN","VPR CORD1",339 ,0)
  6946    ;list Dis continue R eason List
  6947   "RTN","VPR CORD1",340 ,0)
  6948    I ACTION= "DL" D  G  ORDERX
  6949   "RTN","VPR CORD1",341 ,0)
  6950    .D DCLREA S(.RESULT, DFN,ID,ORP ROV)
  6951   "RTN","VPR CORD1",342 ,0)
  6952    ;Disconti nue Order
  6953   "RTN","VPR CORD1",343 ,0)
  6954    I ACTION= "D" D  G O RDERX
  6955   "RTN","VPR CORD1",344 ,0)
  6956    .S REAS=I NFO("dcRea son")
  6957   "RTN","VPR CORD1",345 ,0)
  6958    .D DC(.RE SULT,DFN,I D,ORPROV,L OC,.SNIPPE T,NAME)
  6959   "RTN","VPR CORD1",346 ,0)
  6960    ;Renew Or der
  6961   "RTN","VPR CORD1",347 ,0)
  6962    I ACTION= "RENEW" D   G ORDERX
  6963   "RTN","VPR CORD1",348 ,0)
  6964    .D RENEW( .RESULT,DF N,ID,ORPRO V,CHKONLY, .SNIPPET,N AME,LOC)
  6965   "RTN","VPR CORD1",349 ,0)
  6966    ;
  6967   "RTN","VPR CORD1",350 ,0)
  6968    I ACTION= "P" D  G O RDERX
  6969   "RTN","VPR CORD1",351 ,0)
  6970    .N ORDIAL OG
  6971   "RTN","VPR CORD1",352 ,0)
  6972    .M ORDIAL OG=VPROARR Y
  6973   "RTN","VPR CORD1",353 ,0)
  6974    .S SAVEAR R("ORCHECK ")=0,SAVEA RR("ORTS") =0
  6975   "RTN","VPR CORD1",354 ,0)
  6976    .I PACTIO N="Q" D SA VE(.RESULT ,DFN,ORPRO V,LOC,VARS ARR("DIALO G NAME"),V ARSARR("DI SPLAY GROU P IEN"),ID ,0,.SAVEAR R)
  6977   "RTN","VPR CORD1",355 ,0)
  6978    .i PACTIO N="C" D SA VE(.RESULT ,DFN,ORPRO V,LOC,VARS ARR("DIALO G NAME"),V ARSARR("DI SPLAY GROU P IEN"),0, ID,.SAVEAR R)
  6979   "RTN","VPR CORD1",356 ,0)
  6980    .I $L($G( RESULT("re sultText") ))>0 S RES ULT("resul tText")=TE MP_$C(13,1 0)_RESULT( "resultTex t")
  6981   "RTN","VPR CORD1",357 ,0)
  6982    ;
  6983   "RTN","VPR CORD1",358 ,0)
  6984    I ACTION= "QL" D  G  ORDERX
  6985   "RTN","VPR CORD1",359 ,0)
  6986    .D QOL(.R ESULT,LOC, ORPROV,ID)
  6987   "RTN","VPR CORD1",360 ,0)
  6988    ;
  6989   "RTN","VPR CORD1",361 ,0)
  6990   ORDERX ;
  6991   "RTN","VPR CORD1",362 ,0)
  6992    I '$D(ERR OR) D BLDJ SON^VPRCOR D2(.RESULT ,.VPROARRY ,.VPRPOSS, .VPRVALUE, SNIPPET,UI D)
  6993   "RTN","VPR CORD1",363 ,0)
  6994    ;I $D(ERR OR) M VPRV ALUE=ERROR
  6995   "RTN","VPR CORD1",364 ,0)
  6996    I $D(ERRO R) D ENCOD E^VPRJSON( "ERROR","V PRVALUE"," VPRERR")
  6997   "RTN","VPR CORD1",365 ,0)
  6998    ;M ^XTMP( "AGP INFO" )=VPRVALUE
  6999   "RTN","VPR CORD1",366 ,0)
  7000    Q
  7001   "RTN","VPR CORD1",367 ,0)
  7002    ;
  7003   "RTN","VPR CORD2")
  7004   0^8^B67716 889
  7005   "RTN","VPR CORD2",1,0 )
  7006   VPRCORD2 ; ;SLC/AGP -  Process O rder Reque st from AV IVA System  ; 11/2/10  11:39am
  7007   "RTN","VPR CORD2",2,0 )
  7008    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  7009   "RTN","VPR CORD2",3,0 )
  7010    ;
  7011   "RTN","VPR CORD2",4,0 )
  7012    ;The purp ose of thi s API is t o process  a request  to renew a n
  7013   "RTN","VPR CORD2",5,0 )
  7014    ;Outpatie nt Prescri ption
  7015   "RTN","VPR CORD2",6,0 )
  7016    ;
  7017   "RTN","VPR CORD2",7,0 )
  7018    Q
  7019   "RTN","VPR CORD2",8,0 )
  7020    ;
  7021   "RTN","VPR CORD2",9,0 )
  7022    ;add poss ible value s from the  dialog to  XML List  return for  each prom pt
  7023   "RTN","VPR CORD2",10, 0)
  7024   ADDPOSS(PO SS,RESULT)  ;
  7025   "RTN","VPR CORD2",11, 0)
  7026    N CNT,ISF IRST,NUM,L AST,PROMPT ,TEMP
  7027   "RTN","VPR CORD2",12, 0)
  7028    ;S RESULT ("possible Values")=" "
  7029   "RTN","VPR CORD2",13, 0)
  7030    M RESULT= POSS
  7031   "RTN","VPR CORD2",14, 0)
  7032    S ISFIRST =1,LAST="" ,PROMPT=""
  7033   "RTN","VPR CORD2",15, 0)
  7034    ;F  S PRO MPT=$O(POS S(PROMPT))  Q:PROMPT= ""  D
  7035   "RTN","VPR CORD2",16, 0)
  7036    ;.S TEMP= PROMPT_"s" ,LAST=PROM PT
  7037   "RTN","VPR CORD2",17, 0)
  7038    ;.S RESUL T("possibl eValues",T EMP)=""
  7039   "RTN","VPR CORD2",18, 0)
  7040    ;.S CNT=" ",NUM=0 F   S CNT=$O( POSS(PROMP T,CNT)) Q: CNT=""  
  7041   "RTN","VPR CORD2",19, 0)
  7042    ;..S RESU LT("possib leValues", TEMP,NUM," value")=PO SS(PROMPT, CNT),NUM=N UM+1
  7043   "RTN","VPR CORD2",20, 0)
  7044    Q
  7045   "RTN","VPR CORD2",21, 0)
  7046    ;
  7047   "RTN","VPR CORD2",22, 0)
  7048   ARRREAS(RE AS,UID) ;
  7049   "RTN","VPR CORD2",23, 0)
  7050    I '$D(^XT MP("VPR SN IPPET",DFN ,DT)) S ^X TMP("VPR S NIPPET",0) =""
  7051   "RTN","VPR CORD2",24, 0)
  7052    N CNT S C NT=$O(^XTM P("VPR SNI PPET",DFN, DT,""),-1)
  7053   "RTN","VPR CORD2",25, 0)
  7054    S CNT=CNT +1
  7055   "RTN","VPR CORD2",26, 0)
  7056    S ^XTMP(" VPR SNIPPE T",DFN,DT, CNT)=""
  7057   "RTN","VPR CORD2",27, 0)
  7058    S ^XTMP(" VPR SNIPPE T",DFN,DT, CNT,"text" )=REAS
  7059   "RTN","VPR CORD2",28, 0)
  7060    I $G(UID) '="" S ^XT MP("VPR SN IPPET",DFN ,DT,CNT,"u id")=UID
  7061   "RTN","VPR CORD2",29, 0)
  7062    Q
  7063   "RTN","VPR CORD2",30, 0)
  7064    ;
  7065   "RTN","VPR CORD2",31, 0)
  7066    ;initial  API needed  for order  actions a nd QO
  7067   "RTN","VPR CORD2",32, 0)
  7068   BEG(DFN,LO C,IEN,USER ,VARSARR,B LDRES,VPRV ALUE) ;
  7069   "RTN","VPR CORD2",33, 0)
  7070    N CNT,FLD S,HASKEY,T EXT,VPRLST
  7071   "RTN","VPR CORD2",34, 0)
  7072    D BLDVAR( DFN,LOC,DT ,.VARSARR)  I VARSARR ("PATIENT" )="" D AE^ VPRCORD1(" Invalid Pa tient",.VP RVALUE) Q  0
  7073   "RTN","VPR CORD2",35, 0)
  7074    D NPHASKE Y^ORWU(.HA SKEY,USER, "PROVIDER" ) I HASKEY =0 D AE^VP RCORD1("DO ES NOT HOL D THE PROV IDER KEY", .VPRVALUE)  Q 0
  7075   "RTN","VPR CORD2",36, 0)
  7076    S FLDS=DF N_U_LOC_U_ USER_U_VAR SARR("ISIN P")_U_VARS ARR("SEX") _U_VARSARR ("AGE")_U_ "0;C;0;0^0 ^^^"
  7077   "RTN","VPR CORD2",37, 0)
  7078    I $P($G(^ ORD(101.41 ,IEN,0)),U ,4)="O" D   Q 1
  7079   "RTN","VPR CORD2",38, 0)
  7080    .S BLDRES (0)="^^^O"
  7081   "RTN","VPR CORD2",39, 0)
  7082    .D LOADSE T^ORWDXM(. VPRLST,IEN )
  7083   "RTN","VPR CORD2",40, 0)
  7084    .S CNT=0  F  S CNT=$ O(VPRLST(C NT)) Q:CNT '>0  D
  7085   "RTN","VPR CORD2",41, 0)
  7086    ..S BLDRE S(CNT)=VPR LST(CNT)
  7087   "RTN","VPR CORD2",42, 0)
  7088    D BLDQRSP ^ORWDXM1(. BLDRES,IEN ,FLDS,VARS ARR("ISIMO "),LOC)
  7089   "RTN","VPR CORD2",43, 0)
  7090    K ^TMP("O RWDXMQ",$J )
  7091   "RTN","VPR CORD2",44, 0)
  7092    I +BLDRES (0)=8 D AE ^VPRCORD1( BLDRES(.5) ,.VPRVALUE ) Q 0
  7093   "RTN","VPR CORD2",45, 0)
  7094    Q 1
  7095   "RTN","VPR CORD2",46, 0)
  7096    ;
  7097   "RTN","VPR CORD2",47, 0)
  7098    ;builds m ultiple ar rays from  the ORDIAL OG array.
  7099   "RTN","VPR CORD2",48, 0)
  7100    ;builds X ML return  structure  of the dia log,
  7101   "RTN","VPR CORD2",49, 0)
  7102    ;ORDERCHK  array for  order che cks when p lacing an  order
  7103   "RTN","VPR CORD2",50, 0)
  7104    ;SAVEARR  array for  saving an  order for  QO
  7105   "RTN","VPR CORD2",51, 0)
  7106   BLDARRS(RE SULT,ORDIA LOG,VARSAR R,DFN,LOC, ORDERCHK,S AVEARR,POS S) ;
  7107   "RTN","VPR CORD2",52, 0)
  7108    ;D ADD("< dialog>")
  7109   "RTN","VPR CORD2",53, 0)
  7110    N CNT,DEF ,DRUG,EXT, FILLER,INC ,IEN,INST, NODE,PROMP T,SCH,STR, TEMP,VALUE ,X,ZERO
  7111   "RTN","VPR CORD2",54, 0)
  7112    D SCHALL^ ORWDPS1(.S CH,DFN,LOC )
  7113   "RTN","VPR CORD2",55, 0)
  7114    S RESULT( "name")=VA RSARR("DIA LOG NAME") ,RESULT("d isplayGrou p")=VARSAR R("DISPLAY  GROUP")
  7115   "RTN","VPR CORD2",56, 0)
  7116    S IEN=$$P TR("ORDERA BLE ITEM")
  7117   "RTN","VPR CORD2",57, 0)
  7118    S OI=ORDI ALOG(IEN,1 ),FILLER=V ARSARR("FI LLER ID")
  7119   "RTN","VPR CORD2",58, 0)
  7120    D LOADPOS S(DFN,LOC, OI,FILLER, .VARSARR,. POSS)
  7121   "RTN","VPR CORD2",59, 0)
  7122    S CNT=0,I EN=0,INC=0  F  S IEN= $O(ORDIALO G(IEN)) Q: IEN'>0  D
  7123   "RTN","VPR CORD2",60, 0)
  7124    .S NODE=$ G(ORDIALOG (IEN)),ZER O=ORDIALOG (IEN,0)
  7125   "RTN","VPR CORD2",61, 0)
  7126    .S PROMPT =$P(NODE,U ,2),CNT=CN T+1,INC=IN C+1
  7127   "RTN","VPR CORD2",62, 0)
  7128    .S RESULT ("structur e",INC,"na me")=PROMP T,RESULT(" structure" ,INC,"id") =$P(NODE,U )
  7129   "RTN","VPR CORD2",63, 0)
  7130    .S TEMP=$ S(PROMPT=" DOSE":"ALL DOSES",PRO MPT="DRUG" :"DISPENSE ",1:PROMPT )
  7131   "RTN","VPR CORD2",64, 0)
  7132    .;I $D(PO SS(TEMP))  D ADDPOSS( TEMP,.POSS )
  7133   "RTN","VPR CORD2",65, 0)
  7134    .I $P(ZER O,U)="S" D  LOADPOSC( PROMPT,$P( ZERO,U,2), .POSS)
  7135   "RTN","VPR CORD2",66, 0)
  7136    .;D ADD(" <instances >")
  7137   "RTN","VPR CORD2",67, 0)
  7138    .S X=$O(O RDIALOG(IE N,99),-1)
  7139   "RTN","VPR CORD2",68, 0)
  7140    .;I X=0 D   Q
  7141   "RTN","VPR CORD2",69, 0)
  7142    .;.S VALU E=$O(POSS( PROMPT,"DE FAULT","") ) I VALUE= "" D  Q
  7143   "RTN","VPR CORD2",70, 0)
  7144    .;..D ADD ("</instan ces>")
  7145   "RTN","VPR CORD2",71, 0)
  7146    .;..D ADD ("</prompt >")
  7147   "RTN","VPR CORD2",72, 0)
  7148    .;.D ADD( "<default  value='"_$ $ESC^VPRD( VALUE)_"'/ >")
  7149   "RTN","VPR CORD2",73, 0)
  7150    .;.D ADD( "</instanc es>")
  7151   "RTN","VPR CORD2",74, 0)
  7152    .;.D ADD( "</prompt> ")
  7153   "RTN","VPR CORD2",75, 0)
  7154    .F INST=1 :1:X D
  7155   "RTN","VPR CORD2",76, 0)
  7156    ..S VALUE =ORDIALOG( IEN,INST)
  7157   "RTN","VPR CORD2",77, 0)
  7158    ..I VALUE ["^TMP(" D   Q
  7159   "RTN","VPR CORD2",78, 0)
  7160    ... I $G( @VALUE@(1, 0))="" Q
  7161   "RTN","VPR CORD2",79, 0)
  7162    ...S SAVE ARR(IEN,IN ST)="ORDIA LOG(""WP"" ,"_IEN_",1 )"
  7163   "RTN","VPR CORD2",80, 0)
  7164    ...S SAVE ARR("WP",I EN,INST,1, 0)=@VALUE@ (1,0)
  7165   "RTN","VPR CORD2",81, 0)
  7166    ..S SAVEA RR(IEN,INS T)=VALUE
  7167   "RTN","VPR CORD2",82, 0)
  7168    ..S EXT=$ $EXT^ORCD( IEN,INST)
  7169   "RTN","VPR CORD2",83, 0)
  7170    ..S ORDER CHK(CNT)=F ILLER_U_PR OMPT_U_VAL UE_U_EXT,C NT=CNT+1
  7171   "RTN","VPR CORD2",84, 0)
  7172    ..S RESUL T("structu re",INC,"i nstance",I NST,"numbe r")=INST
  7173   "RTN","VPR CORD2",85, 0)
  7174    ..S RESUL T("structu re",INC,"i nstance",I NST,"value ")=VALUE
  7175   "RTN","VPR CORD2",86, 0)
  7176    ..S RESUL T("structu re",INC,"i nstance",I NST,"exter nal")=EXT
  7177   "RTN","VPR CORD2",87, 0)
  7178    ..I PROMP T="ORDERAB LE" S OI=V ALUE
  7179   "RTN","VPR CORD2",88, 0)
  7180    ..W !,PRO MPT_" "_$G (VALUE)
  7181   "RTN","VPR CORD2",89, 0)
  7182    ..I PROMP T="DRUG" S  DRUG=$G(V ALUE)
  7183   "RTN","VPR CORD2",90, 0)
  7184    W !,FILLE R
  7185   "RTN","VPR CORD2",91, 0)
  7186    S ORDERCH K(1)=OI_U_ FILLER_U_$ S(FILLER[" PS":$G(DRU G),1:"")
  7187   "RTN","VPR CORD2",92, 0)
  7188    Q
  7189   "RTN","VPR CORD2",93, 0)
  7190    ;
  7191   "RTN","VPR CORD2",94, 0)
  7192    ;build pa tient demo graphic va riables
  7193   "RTN","VPR CORD2",95, 0)
  7194   BLDVAR(DFN ,LOC,DATE, OUTPUT) ;
  7195   "RTN","VPR CORD2",96, 0)
  7196    N IMO,TEM P
  7197   "RTN","VPR CORD2",97, 0)
  7198    I $L(DFN) '>0 S OUTP UT("PATIEN T")="" Q
  7199   "RTN","VPR CORD2",98, 0)
  7200    S TEMP=$G (^DPT(DFN, 0))
  7201   "RTN","VPR CORD2",99, 0)
  7202    I TEMP=""  S OUTPUT( "PATIENT") ="" Q
  7203   "RTN","VPR CORD2",100 ,0)
  7204    S OUTPUT( "PATIENT") =$P(TEMP,U ,1)
  7205   "RTN","VPR CORD2",101 ,0)
  7206    S OUTPUT( "SEX")=$P( TEMP,U,2)
  7207   "RTN","VPR CORD2",102 ,0)
  7208    S OUTPUT( "DOB")=$P( TEMP,U,3)
  7209   "RTN","VPR CORD2",103 ,0)
  7210    S OUTPUT( "SSN")=$P( TEMP,U,9)
  7211   "RTN","VPR CORD2",104 ,0)
  7212    S OUTPUT( "DOD")=$P( $G(^DPT(DF N,.35)),U, 1)
  7213   "RTN","VPR CORD2",105 ,0)
  7214    I OUTPUT( "DOD")>DAT E S OUTPUT ("DOD")=""
  7215   "RTN","VPR CORD2",106 ,0)
  7216    S OUTPUT( "DFN")=DFN
  7217   "RTN","VPR CORD2",107 ,0)
  7218    S OUTPUT( "AGE")=$$A GE^PXRMAGE (OUTPUT("D OB"),OUTPU T("DOD"),D ATE)
  7219   "RTN","VPR CORD2",108 ,0)
  7220    S OUTPUT( "ISINP")=$ S(+$G(^DPT (DFN,.1))> 0:1,1:0)
  7221   "RTN","VPR CORD2",109 ,0)
  7222    D IMOLOC^ ORIMO(.IMO ,LOC,DFN)
  7223   "RTN","VPR CORD2",110 ,0)
  7224    S OUTPUT( "ISIMO")=$ S(IMO>0:1, 1:0)
  7225   "RTN","VPR CORD2",111 ,0)
  7226    Q
  7227   "RTN","VPR CORD2",112 ,0)
  7228    ;
  7229   "RTN","VPR CORD2",113 ,0)
  7230   BLDJSON(RE SULT,ORDAR R,VPRPOSS, VPRVALUE,R EAS,UID,DA TA) ;
  7231   "RTN","VPR CORD2",114 ,0)
  7232    N CNT,ERR OR,STR,TEM P,TEXT
  7233   "RTN","VPR CORD2",115 ,0)
  7234    S RESULT( "success") ="true"
  7235   "RTN","VPR CORD2",116 ,0)
  7236    I REAS'=" ",UID'=""  D ARRREAS( REAS,UID)
  7237   "RTN","VPR CORD2",117 ,0)
  7238    I $D(VPRP OSS) D ADD POSS(.VPRP OSS)
  7239   "RTN","VPR CORD2",118 ,0)
  7240    I $D(ORDA RR) D
  7241   "RTN","VPR CORD2",119 ,0)
  7242    .S RESULT ("ordered  placed")=" true"
  7243   "RTN","VPR CORD2",120 ,0)
  7244    .S CNT=0  F  S CNT=$ O(ORDARR(C NT)) Q:CNT '>0  D
  7245   "RTN","VPR CORD2",121 ,0)
  7246    ..S TEMP= ORDARR(CNT ),STR=""
  7247   "RTN","VPR CORD2",122 ,0)
  7248    ..I $E(TE MP)="t" S  STR=$E(TEM P,2,$L(TEM P))
  7249   "RTN","VPR CORD2",123 ,0)
  7250    ..I STR'= "" S RESUL T("text")= $G(RESULT( "text"))_S TR_$C(13,1 0)
  7251   "RTN","VPR CORD2",124 ,0)
  7252    I $D(^TMP ($J,"ORDER  CHECKS"))  D
  7253   "RTN","VPR CORD2",125 ,0)
  7254    .S CNT=0  F  S CNT=$ O(^TMP($J, "ORDER CHE CKS",CNT))  Q:CNT'>0   D
  7255   "RTN","VPR CORD2",126 ,0)
  7256    ..S RESUL T("orderCh ecks")=$G( RESULT("or derChecks" ))_^TMP($J ,"ORDER CH ECKS",CNT) _$C(13,10)
  7257   "RTN","VPR CORD2",127 ,0)
  7258    I $D(DATA ) M RESULT ("data")=D ATA
  7259   "RTN","VPR CORD2",128 ,0)
  7260    D ENCODE^ VPRJSON("R ESULT","VP RVALUE","V PRERR")
  7261   "RTN","VPR CORD2",129 ,0)
  7262    I $D(VPRE RR) D
  7263   "RTN","VPR CORD2",130 ,0)
  7264    .K VPRVAL UE S TEXT( 1)="Proble m encoding  save orde r array. C heck CPRS  to see if  the order  was saved. "
  7265   "RTN","VPR CORD2",131 ,0)
  7266    .D SETERR OR^VPRUTIL S(.ERROR,. VPRERR,.TE XT,.DATA)
  7267   "RTN","VPR CORD2",132 ,0)
  7268    .D ENCODE ^VPRJSON(" ERROR","VP RVALUE","V PRERR")
  7269   "RTN","VPR CORD2",133 ,0)
  7270    Q
  7271   "RTN","VPR CORD2",134 ,0)
  7272    ;
  7273   "RTN","VPR CORD2",135 ,0)
  7274   CHANGE(ORD IEN,DFN,LO C,USER,ERR ARR) ;
  7275   "RTN","VPR CORD2",136 ,0)
  7276    N TEXT,VA LUE
  7277   "RTN","VPR CORD2",137 ,0)
  7278    D VALID^O RWDXA(.VAL UE,ORDIEN, "XX",USER)  I VALUE'= "" D AE^VP RCORD1(VAL UE,.VPRVAL UE) Q 0
  7279   "RTN","VPR CORD2",138 ,0)
  7280    D OFCPLX^ ORWDXA(.VA LUE,ORDIEN ) I VALUE' ="" D AE^V PRCORD1("C ANNOT CHAN GE A COMPL EX ORDER", .VPRVALUE)  Q 0
  7281   "RTN","VPR CORD2",139 ,0)
  7282    Q 1
  7283   "RTN","VPR CORD2",140 ,0)
  7284    ;
  7285   "RTN","VPR CORD2",141 ,0)
  7286   INFO(OCHKS ) ;
  7287   "RTN","VPR CORD2",142 ,0)
  7288    N INC,CNT ,NUM,NODE, TEMP,VPROR CK
  7289   "RTN","VPR CORD2",143 ,0)
  7290    S NUM=0,C NT=+$O(^TM P($J,"ORDE R CHECKS", ""),-1)
  7291   "RTN","VPR CORD2",144 ,0)
  7292    F  S NUM= $O(OCHKS(N UM)) Q:NUM '>0  D
  7293   "RTN","VPR CORD2",145 ,0)
  7294    .S NODE=$ P(OCHKS(NU M),U,4)
  7295   "RTN","VPR CORD2",146 ,0)
  7296    .I NODE=" " S NODE=O CHKS(NUM)
  7297   "RTN","VPR CORD2",147 ,0)
  7298    .S TEMP=" "
  7299   "RTN","VPR CORD2",148 ,0)
  7300    .I NODE[" ||",NODE[" &" D
  7301   "RTN","VPR CORD2",149 ,0)
  7302    ..S TEMP= $P(NODE,"& ")
  7303   "RTN","VPR CORD2",150 ,0)
  7304    ..S NODE= $P(NODE,"& ",2)
  7305   "RTN","VPR CORD2",151 ,0)
  7306    .S CNT=CN T+1
  7307   "RTN","VPR CORD2",152 ,0)
  7308    .S ^TMP($ J,"ORDER C HECKS",CNT )=NODE
  7309   "RTN","VPR CORD2",153 ,0)
  7310    .I TEMP'= "" D
  7311   "RTN","VPR CORD2",154 ,0)
  7312    ..D GETXT RA^ORCHECK (.VPRORCK, $P(TEMP,"| |",2),NODE )
  7313   "RTN","VPR CORD2",155 ,0)
  7314    ..S INC=0  F  S INC= $O(VPRORCK (INC)) Q:I NC'>0  D
  7315   "RTN","VPR CORD2",156 ,0)
  7316    ...S CNT= CNT+1
  7317   "RTN","VPR CORD2",157 ,0)
  7318    ...S ^TMP ($J,"ORDER  CHECKS",C NT)=VPRORC K(INC)
  7319   "RTN","VPR CORD2",158 ,0)
  7320    Q
  7321   "RTN","VPR CORD2",159 ,0)
  7322    ;
  7323   "RTN","VPR CORD2",160 ,0)
  7324   KILLALRT(D FN,TYPE) ;
  7325   "RTN","VPR CORD2",161 ,0)
  7326    N VPROUT
  7327   "RTN","VPR CORD2",162 ,0)
  7328    D KILUNSN O^ORWORB(. VPROUT,DFN ) K VPROUT
  7329   "RTN","VPR CORD2",163 ,0)
  7330    I TYPE["P S" D
  7331   "RTN","VPR CORD2",164 ,0)
  7332    . D KILEX MED^ORWORB (.VPROUT,D FN) K VPRO UT
  7333   "RTN","VPR CORD2",165 ,0)
  7334    . D KILUN VMD^ORWORB (.VPROUT,D FN) K VPRO UT
  7335   "RTN","VPR CORD2",166 ,0)
  7336    D KILUNVO R^ORWORB(. VPROUT,DFN ) K VPROUT
  7337   "RTN","VPR CORD2",167 ,0)
  7338    Q
  7339   "RTN","VPR CORD2",168 ,0)
  7340    ;build a  list of po ssible sel ection ite ms for a p rompt
  7341   "RTN","VPR CORD2",169 ,0)
  7342   LOADPOSS(D FN,LOC,OI, FILLER,VAR SARR,POSS)  ;
  7343   "RTN","VPR CORD2",170 ,0)
  7344    N CNT,DGI EN,ID,NUM, PROMPT,STR ,TYPE,VPRP OSS
  7345   "RTN","VPR CORD2",171 ,0)
  7346    S TYPE=$S (FILLER="P SO":"O",1: "I")
  7347   "RTN","VPR CORD2",172 ,0)
  7348    S NUM=0
  7349   "RTN","VPR CORD2",173 ,0)
  7350    S DGIEN=V ARSARR("DI SPLAY GROU P IEN")
  7351   "RTN","VPR CORD2",174 ,0)
  7352    I FILLER[ "PS" D OIS LCT^ORWDPS 2(.VPRPOSS ,OI,TYPE,D FN,"Y","N" )
  7353   "RTN","VPR CORD2",175 ,0)
  7354    I FILLER[ "LR" D DEF ^ORWDLR32( .VPRPOSS,L OC,"")
  7355   "RTN","VPR CORD2",176 ,0)
  7356    I FILLER[ "RA" D DEF ^ORWDRA32( .VPRPOSS,D FN,"",DGIE N)
  7357   "RTN","VPR CORD2",177 ,0)
  7358    S CNT=0
  7359   "RTN","VPR CORD2",178 ,0)
  7360    F  S CNT= $O(VPRPOSS (CNT)) Q:C NT'>0  D
  7361   "RTN","VPR CORD2",179 ,0)
  7362    .S NODE=V PRPOSS(CNT )
  7363   "RTN","VPR CORD2",180 ,0)
  7364    .S TEMP=$ E($G(NODE) ,2,$L(NODE ))
  7365   "RTN","VPR CORD2",181 ,0)
  7366    .I $E(NOD E)="~" D   Q
  7367   "RTN","VPR CORD2",182 ,0)
  7368    ..S NUM=0 ,PROMPT=$$ LOW^XLFSTR (TEMP)
  7369   "RTN","VPR CORD2",183 ,0)
  7370    ..S PROMP T=$TR(PROM PT," ","_" )
  7371   "RTN","VPR CORD2",184 ,0)
  7372    ..S POSS( PROMPT)=""
  7373   "RTN","VPR CORD2",185 ,0)
  7374    ..S NUM=0
  7375   "RTN","VPR CORD2",186 ,0)
  7376    .I PROMPT ="alldoses "!(PROMPT= "route") D   Q
  7377   "RTN","VPR CORD2",187 ,0)
  7378    ..S ID=TE MP
  7379   "RTN","VPR CORD2",188 ,0)
  7380    ..S TEMP= $S(PROMPT= "alldoses" :$P(TEMP,U ),PROMPT=" route":$P( TEMP,U,2), 1:TEMP)
  7381   "RTN","VPR CORD2",189 ,0)
  7382    ..S POSS( $$LOW^XLFS TR(PROMPT) ,NUM,"valu e")=TEMP
  7383   "RTN","VPR CORD2",190 ,0)
  7384    ..S POSS( $$LOW^XLFS TR(PROMPT) ,NUM,"id") =ID
  7385   "RTN","VPR CORD2",191 ,0)
  7386    ..S POSS( $$LOW^XLFS TR(PROMPT) ,NUM,"defa ult")=$S($ E(NODE)="d ":"true",1 :"false")
  7387   "RTN","VPR CORD2",192 ,0)
  7388    ..S NUM=N UM+1
  7389   "RTN","VPR CORD2",193 ,0)
  7390    .S POSS($ $LOW^XLFST R(PROMPT), NUM,"value ")=TEMP
  7391   "RTN","VPR CORD2",194 ,0)
  7392    .;S POSS( $$LOW^XLFS TR(PROMPT) ,NUM,"id") =ID
  7393   "RTN","VPR CORD2",195 ,0)
  7394    .S POSS($ $LOW^XLFST R(PROMPT), NUM,"defau lt")=$S($E (NODE)="d" :"true",1: "false")
  7395   "RTN","VPR CORD2",196 ,0)
  7396    .S NUM=NU M+1
  7397   "RTN","VPR CORD2",197 ,0)
  7398    ;build li st of poss ible sched ules
  7399   "RTN","VPR CORD2",198 ,0)
  7400    I FILLER[ "PS" D
  7401   "RTN","VPR CORD2",199 ,0)
  7402    .D SCHALL ^ORWDPS1(. SCH,DFN,LO C)
  7403   "RTN","VPR CORD2",200 ,0)
  7404    .S NUM=0
  7405   "RTN","VPR CORD2",201 ,0)
  7406    .S CNT=0  F  S CNT=$ O(SCH(CNT) ) Q:CNT'>0   D
  7407   "RTN","VPR CORD2",202 ,0)
  7408    ..S TEMP= SCH(CNT)
  7409   "RTN","VPR CORD2",203 ,0)
  7410    ..S POSS( "schedule" ,NUM,"valu e")=$P(TEM P,U)
  7411   "RTN","VPR CORD2",204 ,0)
  7412    ..S POSS( "schedule" ,NUM,"exte rnal")=$P( TEMP,U,2)
  7413   "RTN","VPR CORD2",205 ,0)
  7414    ..S POSS( "schedule" ,NUM,"type ")=$P(TEMP ,U,3)
  7415   "RTN","VPR CORD2",206 ,0)
  7416    ..S POSS( "schedule" ,NUM,"admi n")=$P(TEM P,U,4)
  7417   "RTN","VPR CORD2",207 ,0)
  7418    ..S NUM=N UM+1
  7419   "RTN","VPR CORD2",208 ,0)
  7420    Q
  7421   "RTN","VPR CORD2",209 ,0)
  7422    ;
  7423   "RTN","VPR CORD2",210 ,0)
  7424    ;;add pos sible code  values fr om the dia log to XML  return fo r each pro mpt
  7425   "RTN","VPR CORD2",211 ,0)
  7426   LOADPOSC(P ROMPT,CODE S,POSS) ;
  7427   "RTN","VPR CORD2",212 ,0)
  7428    N CNT,STR ,NUM,TEMP
  7429   "RTN","VPR CORD2",213 ,0)
  7430    S TEMP=$$ LOW^XLFSTR (PROMPT),P OSS(TEMP)= "",NUM=0,C NT=0
  7431   "RTN","VPR CORD2",214 ,0)
  7432    F X=1:1:$ L(CODES) I  $E(CODES, X)=";" D
  7433   "RTN","VPR CORD2",215 ,0)
  7434    .S CNT=CN T+1,STR=$P (CODES,";" ,CNT) Q:ST R=""
  7435   "RTN","VPR CORD2",216 ,0)
  7436    .S POSS(T EMP,NUM,"v alue")=$P( STR,":",2) ,POSS(TEMP ,NUM,"id") =$P(STR,": "),NUM=NUM +1
  7437   "RTN","VPR CORD2",217 ,0)
  7438    Q
  7439   "RTN","VPR CORD2",218 ,0)
  7440   PTR(NAME)  ; -- Retur ns ptr val ue of prom pt in Dial og file
  7441   "RTN","VPR CORD2",219 ,0)
  7442    Q +$O(^OR D(101.41," AB",$E("OR  GTX "_NAM E,1,63),0) )
  7443   "RTN","VPR CORD2",220 ,0)
  7444    ;
  7445   "RTN","VPR CORD2",221 ,0)
  7446   UNSIGNED(U IFN) ;queu e unsigned  order ale rt
  7447   "RTN","VPR CORD2",222 ,0)
  7448    N ORVP,OR IFN,ORNP,A
  7449   "RTN","VPR CORD2",223 ,0)
  7450    Q:$G(UIFN )=""  S A= $G(^OR(100 ,UIFN,0)), ORVP=$P(A, "^",2),ORN P=$P(A,"^" ,4),ORIFN= UIFN_";1"
  7451   "RTN","VPR CORD2",224 ,0)
  7452    D NOTIF^O RCSIGN
  7453   "RTN","VPR CORD2",225 ,0)
  7454    Q
  7455   "RTN","VPR CORD3")
  7456   0^45^B1513 71865
  7457   "RTN","VPR CORD3",1,0 )
  7458   VPRCORD3 ; ;SLC/AGP -  Process O rder Reque st from AV IVA System  ; 1/4/13
  7459   "RTN","VPR CORD3",2,0 )
  7460    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  7461   "RTN","VPR CORD3",3,0 )
  7462    ;
  7463   "RTN","VPR CORD3",4,0 )
  7464    ;
  7465   "RTN","VPR CORD3",5,0 )
  7466    Q
  7467   "RTN","VPR CORD3",6,0 )
  7468    ;
  7469   "RTN","VPR CORD3",7,0 )
  7470   BLDDIAL(OR DIALOG,DG, DIAL) ;
  7471   "RTN","VPR CORD3",8,0 )
  7472    D GETDLG^ ORCD(DIAL)
  7473   "RTN","VPR CORD3",9,0 )
  7474    Q
  7475   "RTN","VPR CORD3",10, 0)
  7476    ;
  7477   "RTN","VPR CORD3",11, 0)
  7478   BLDROUTE(V PRROUTE) ;
  7479   "RTN","VPR CORD3",12, 0)
  7480    N IEN,NOD E
  7481   "RTN","VPR CORD3",13, 0)
  7482    S IEN=0 F   S IEN=$O (^PS(51.2, IEN)) Q:IE N'>0  D
  7483   "RTN","VPR CORD3",14, 0)
  7484    .;I $L($G (^PS(51.2, IEN,1)))'= "" Q
  7485   "RTN","VPR CORD3",15, 0)
  7486    .S NODE=$ G(^PS(51.2 ,IEN,0))
  7487   "RTN","VPR CORD3",16, 0)
  7488    .S VPRROU TE($P(NODE ,U))=IEN_U _$S($P(NOD E,U)'="":$ P(NODE,U), 1:$P(NODE, U))
  7489   "RTN","VPR CORD3",17, 0)
  7490    .I $P(NOD E,U,2)'=""  S VPRROUT E($P(NODE, U,2))=IEN
  7491   "RTN","VPR CORD3",18, 0)
  7492    .I $P(NOD E,U,3)'=""  S VPRROUT E($P(NODE, U,3))=IEN
  7493   "RTN","VPR CORD3",19, 0)
  7494    Q
  7495   "RTN","VPR CORD3",20, 0)
  7496    ;
  7497   "RTN","VPR CORD3",21, 0)
  7498   BLDVALS(IN ,OUT,ERROR ) ;
  7499   "RTN","VPR CORD3",22, 0)
  7500    N NUM,LAS T,SPACES,S TR,X
  7501   "RTN","VPR CORD3",23, 0)
  7502    S LAST=""
  7503   "RTN","VPR CORD3",24, 0)
  7504    S NUM=$L( IN,";")
  7505   "RTN","VPR CORD3",25, 0)
  7506    F X=1:1:N UM D
  7507   "RTN","VPR CORD3",26, 0)
  7508    .;W !,X_"  "_$P(IN," :",X)
  7509   "RTN","VPR CORD3",27, 0)
  7510    .S STR=$P (IN,";",X)
  7511   "RTN","VPR CORD3",28, 0)
  7512    .I X=1 S  OUT(STR)=" " S LAST=S TR Q
  7513   "RTN","VPR CORD3",29, 0)
  7514    .I X=NUM  S OUT(LAST )=STR Q
  7515   "RTN","VPR CORD3",30, 0)
  7516    .S SPACES =$L(STR,"  ")
  7517   "RTN","VPR CORD3",31, 0)
  7518    .I LAST'= "" S OUT(L AST)=$P(ST R," ",1,SP ACES-1)
  7519   "RTN","VPR CORD3",32, 0)
  7520    .S LAST=$ P(STR," ", SPACES)
  7521   "RTN","VPR CORD3",33, 0)
  7522    Q
  7523   "RTN","VPR CORD3",34, 0)
  7524    ;
  7525   "RTN","VPR CORD3",35, 0)
  7526   GETOCPKG(V PRTYPE) ;
  7527   "RTN","VPR CORD3",36, 0)
  7528    N RESULT
  7529   "RTN","VPR CORD3",37, 0)
  7530    S RESULT= $S(VPRTYPE ="UD RX":" PSI",VPRTY PE="O RX": "PSO",VPRT YPE="NV RX ":"PSH",1: VPRTYPE)
  7531   "RTN","VPR CORD3",38, 0)
  7532    Q RESULT
  7533   "RTN","VPR CORD3",39, 0)
  7534    ;
  7535   "RTN","VPR CORD3",40, 0)
  7536   GETSET(TYP E) ;
  7537   "RTN","VPR CORD3",41, 0)
  7538    S RESULT= $S(TYPE="I NPATIENT M EDS":"UD R X",TYPE="O UTPATIENT  MEDS":"O R X",TYPE="M EDICATIONS ":"RX",TYP E="NON-VA  MEDS":"NV  RX",1:TYPE )
  7539   "RTN","VPR CORD3",42, 0)
  7540    Q RESULT
  7541   "RTN","VPR CORD3",43, 0)
  7542    ;
  7543   "RTN","VPR CORD3",44, 0)
  7544   EN(VPRVALU E,PARAMS)  ;
  7545   "RTN","VPR CORD3",45, 0)
  7546    N DG,DIAL ,DLGNAME,E RROR,FAIL, ISIMO,LOC, OIIEN,ORDE RSTR,ORDIA LOG,PAT,PA RDG,TEMPTY PE,VPRCHEC K,VPROREST ,VPRTEMP,V PRTYPE,TYP E,VALUES
  7547   "RTN","VPR CORD3",46, 0)
  7548    K ^TMP("V PRWORD",$J ),^TMP("VP RSIG",$J), ^TMP($J,"O RDER CHECK S")
  7549   "RTN","VPR CORD3",47, 0)
  7550    S ORDERST R=$$UP^XLF STR($G(PAR AMS("order String")))  I $G(ORDE RSTR)="" D  AE^VPRCOR D1("No ord er string  found",.ER ROR) G ENX
  7551   "RTN","VPR CORD3",48, 0)
  7552    S TYPE=$$ UP^XLFSTR( $G(PARAMS( "type")))  I TYPE=""  D AE^VPRCO RD1("No or der type f ound",.VPR VALUE) G E NX
  7553   "RTN","VPR CORD3",49, 0)
  7554    S PAT=$G( PARAMS("pa tient")),L OC=$G(PARA MS("locati on")),USER =1089
  7555   "RTN","VPR CORD3",50, 0)
  7556    ;
  7557   "RTN","VPR CORD3",51, 0)
  7558    D IMOLOC^ ORIMO(.VPR TEMP,LOC,P AT) S ISIM O=VPRTEMP
  7559   "RTN","VPR CORD3",52, 0)
  7560    ;builds o rder order  values ar ray this c ode needs  to be enha nced someh ow
  7561   "RTN","VPR CORD3",53, 0)
  7562    D BLDVALS (ORDERSTR, .VALUES,.E RROR) I $D (ERROR) G  ENX
  7563   "RTN","VPR CORD3",54, 0)
  7564    S VALUES( "LOCATION" )=LOC
  7565   "RTN","VPR CORD3",55, 0)
  7566    I $D(PARA MS("COMMEN TS")) M VA LUES("COMM ENTS")=PAR AMS("COMME NTS")
  7567   "RTN","VPR CORD3",56, 0)
  7568    I $D(VALU ES("QO"))  D QO(.ERRO R,.VALUES, LOC,PAT,IS IMO,.ORD)  G ENX
  7569   "RTN","VPR CORD3",57, 0)
  7570    S VPRTYPE =$$GETSET( TYPE) I VP RTYPE="" D  AE^VPRCOR D1("Cannot  find orde r package. ",.ERROR)  G ENX
  7571   "RTN","VPR CORD3",58, 0)
  7572    S DG=$O(^ ORD(100.98 ,"B",VPRTY PE,"")) I  DG="" D AE ^VPRCORD1( "Cannot fi nd display  group.",. ERROR) G E NX
  7573   "RTN","VPR CORD3",59, 0)
  7574    S TEMPTYP E="" I VPR TYPE=TYPE  S TEMPTYPE =$P(^ORD(1 00.98,DG,0 ),U,3)
  7575   "RTN","VPR CORD3",60, 0)
  7576    S OIIEN=+ $$VALIDOI( .VALUES,$S (TEMPTYPE' ="":TEMPTY PE,1:VPRTY PE)) I OII EN<1 D AE^ VPRCORD1(" Cannot fin d valid OI ",.ERROR)  G ENX
  7577   "RTN","VPR CORD3",61, 0)
  7578    S VALUES( "ORDERABLE  ITEM")=OI IEN_U_VALU ES("OI")
  7579   "RTN","VPR CORD3",62, 0)
  7580    ;
  7581   "RTN","VPR CORD3",63, 0)
  7582    ;get disp lay group  info and d ialog info rmation
  7583   "RTN","VPR CORD3",64, 0)
  7584    S FAIL=0, DIAL=+$P($ G(^ORD(100 .98,DG,0)) ,U,4) I DI AL<1 D  I  FAIL=1 D A E^VPRCORD1 ("Cannot f ind dialog .",.ERROR)  G ENX
  7585   "RTN","VPR CORD3",65, 0)
  7586    .S PARDG= $O(^ORD(10 0.98,"AD", DG,"")) I  PARDG'>0 S  FAIL=1 Q
  7587   "RTN","VPR CORD3",66, 0)
  7588    .S DIAL=+ $P($G(^ORD (100.98,PA RDG,0)),U, 4) I DIAL< 1 S FAIL=1
  7589   "RTN","VPR CORD3",67, 0)
  7590    S DLGNAME =$P($G(^OR D(101.41,D IAL,0)),U)
  7591   "RTN","VPR CORD3",68, 0)
  7592    ;
  7593   "RTN","VPR CORD3",69, 0)
  7594    ;get pack age inform ation
  7595   "RTN","VPR CORD3",70, 0)
  7596    S PKGID=$ P(^ORD(101 .41,DIAL,0 ),U,7) I P KGID<0 D A E^VPRCORD1 ("Cannot f ind packag e",.ERROR)  G ENX
  7597   "RTN","VPR CORD3",71, 0)
  7598    S PKGNAME =$P(^DIC(9 .4,PKGID,0 ),U,2) I P KGNAME=""  D AE^VPRCO RD1("Canno t find pac kage name" ,.ERROR) G  ENX
  7599   "RTN","VPR CORD3",72, 0)
  7600    ;
  7601   "RTN","VPR CORD3",73, 0)
  7602    ;create O RDIALOG ar ray
  7603   "RTN","VPR CORD3",74, 0)
  7604    D BLDDIAL (.ORDIALOG ,DG,DIAL)  I '$D(ORDI ALOG) D AE ^VPRCORD1( "Could not  build ORD IALOG arra y",.ERROR)  G ENX
  7605   "RTN","VPR CORD3",75, 0)
  7606    ;populate  ORDIALOG  array with  values
  7607   "RTN","VPR CORD3",76, 0)
  7608    I $$POPDI AL(.ERROR, .ORDIALOG, .VPRCHECK, .VALUES,VP RTYPE,OIIE N,PAT,LOC) <1 G ENX
  7609   "RTN","VPR CORD3",77, 0)
  7610    ;
  7611   "RTN","VPR CORD3",78, 0)
  7612    D PERCHCK S(.ERROR,. ORDIALOG,. VPRCHECK,P AT,LOC,USE R,DIAL,DLG NAME,DG,PK GID,PKGNAM E,OIIEN,"N ") I $D(ER ROR) G ENX
  7613   "RTN","VPR CORD3",79, 0)
  7614    ;
  7615   "RTN","VPR CORD3",80, 0)
  7616    D SAVE(.V PROREST,PA T,USER,LOC ,DLGNAME,D G,OIIEN,0, .ORDIALOG, .ORD)
  7617   "RTN","VPR CORD3",81, 0)
  7618    ;
  7619   "RTN","VPR CORD3",82, 0)
  7620   ENX ;
  7621   "RTN","VPR CORD3",83, 0)
  7622    I $D(ERRO R) D ENCOD E^VPRJSON( "ERROR","V PRVALUE"," VPRERR") Q
  7623   "RTN","VPR CORD3",84, 0)
  7624    ;I $D(ERR OR) M VPRV ALUE=ERROR  Q
  7625   "RTN","VPR CORD3",85, 0)
  7626    D BLDJSON ^VPRCORD2( "",.VPRORE ST,"",.VPR VALUE,""," ",.ORD)
  7627   "RTN","VPR CORD3",86, 0)
  7628    Q
  7629   "RTN","VPR CORD3",87, 0)
  7630    ;
  7631   "RTN","VPR CORD3",88, 0)
  7632   ORDRCHKS(P AT,VPROIFN ,VPRPKG,LO C,ORDIALOG ,VPRCHECK)  ;
  7633   "RTN","VPR CORD3",89, 0)
  7634    N A,OCO,O CLIST,ORIN FO,ORL,OCH KS,PATTYPE ,VPRREN,VP RPOSS
  7635   "RTN","VPR CORD3",90, 0)
  7636    S PATTYPE =$S(+$G(^D PT(PAT,.1) )>0:"I",1: "O")
  7637   "RTN","VPR CORD3",91, 0)
  7638    D ON^ORWD XC(.OCO)
  7639   "RTN","VPR CORD3",92, 0)
  7640    D DISPLAY ^ORWDXC(.O CLIST,PAT, VPRPKG) I  $D(OCLIST)  D INFO^VP RCORD2(.OC LIST)
  7641   "RTN","VPR CORD3",93, 0)
  7642    D ACCEPT^ ORWDXC(.OC HKS,PAT,VP RPKG,PATTY PE,LOC,.VP RCHECK,VPR OIFN,0) I  $D(OCHKS)  D INFO^VPR CORD2(.OCH KS)
  7643   "RTN","VPR CORD3",94, 0)
  7644    Q
  7645   "RTN","VPR CORD3",95, 0)
  7646    ;
  7647   "RTN","VPR CORD3",96, 0)
  7648   PERCHCKS(E RROR,ORDIA LOG,VPRCHE CK,PAT,LOC ,USER,DIAL ,DLGNAME,D G,PKGID,PK GNAME,OIIE N,ORTYPE)  ;
  7649   "RTN","VPR CORD3",97, 0)
  7650    D NPHASKE Y^ORWU(.HA SKEY,USER, "PROVIDER" ) I HASKEY =0 D AE^VP RCORD1("DO ES NOT HOL D THE PROV IDER KEY", .ERROR) Q
  7651   "RTN","VPR CORD3",98, 0)
  7652    D ALLWORD ^ORALWORD( .VPROK,USE R,OIIEN,OR TYPE,USER)  I $G(VPRO K)>0 D AEM ^VPRCORD1( .VPROK,.ER ROR) Q
  7653   "RTN","VPR CORD3",99, 0)
  7654    D ORDRCHK S(PAT,OIIE N,PKGNAME, LOC,.ORDIA LOG,.VPRCH ECK)
  7655   "RTN","VPR CORD3",100 ,0)
  7656    Q
  7657   "RTN","VPR CORD3",101 ,0)
  7658    ;
  7659   "RTN","VPR CORD3",102 ,0)
  7660   POPDIAL(ER ROR,ORDIAL OG,VPRCHEC K,VALUES,V PRTYPE,OII EN,PAT,LOC ) ;
  7661   "RTN","VPR CORD3",103 ,0)
  7662    N CNT,NAM E,NODE,NUM ,OCPKG,PTR ,RESULT,TE MP,WP
  7663   "RTN","VPR CORD3",104 ,0)
  7664    S RESULT= 0
  7665   "RTN","VPR CORD3",105 ,0)
  7666    I VPRTYPE ["RX" S RE SULT=$$PS( .ERROR,.OR DIALOG,.VA LUES,VPRTY PE,OIIEN,P AT,LOC) I  RESULT=0 Q  0
  7667   "RTN","VPR CORD3",106 ,0)
  7668    S RESULT= $$ORDDIAL( .ERROR,.OR DIALOG,.VA LUES,VPRTY PE,OIIEN,P AT,LOC) I  RESULT=0 Q  0
  7669   "RTN","VPR CORD3",107 ,0)
  7670    ;
  7671   "RTN","VPR CORD3",108 ,0)
  7672    S NAME=""  F  S NAME =$O(VALUES (NAME)) Q: NAME=""  D
  7673   "RTN","VPR CORD3",109 ,0)
  7674    .S PTR=+$ $PTR(NAME)  I PTR=0 Q
  7675   "RTN","VPR CORD3",110 ,0)
  7676    .I '$D(OR DIALOG(PTR )) Q
  7677   "RTN","VPR CORD3",111 ,0)
  7678    .S ORDIAL OG(PTR,1)= $P(VALUES( NAME),U)
  7679   "RTN","VPR CORD3",112 ,0)
  7680    .I NAME=" SIG"!(NAME ="WORD PRO CESSING 1" ) S ORDIAL OG(PTR,1)= VALUES(NAM E)
  7681   "RTN","VPR CORD3",113 ,0)
  7682    .S TEMP(P TR)=VALUES (NAME)
  7683   "RTN","VPR CORD3",114 ,0)
  7684    ;
  7685   "RTN","VPR CORD3",115 ,0)
  7686    D POPOC(. ERROR,.ORD IALOG,.TEM P,.VPRCHEC K,VPRTYPE, OIIEN)
  7687   "RTN","VPR CORD3",116 ,0)
  7688    Q RESULT
  7689   "RTN","VPR CORD3",117 ,0)
  7690    ;
  7691   "RTN","VPR CORD3",118 ,0)
  7692   POPOC(ERRO R,ORDIALOG ,TEMP,VPRC HECK,VPRTY PE,OIIEN)  ;
  7693   "RTN","VPR CORD3",119 ,0)
  7694    N CNT,NAM E,NODE,NUM ,OCPKG,PTR ,WP
  7695   "RTN","VPR CORD3",120 ,0)
  7696    S OCPKG=$ $GETOCPKG( $G(VPRTYPE )) I OCPKG ="" Q
  7697   "RTN","VPR CORD3",121 ,0)
  7698    S CNT=1 S  VPRCHECK( CNT)=OIIEN _U_OCPKG_U
  7699   "RTN","VPR CORD3",122 ,0)
  7700    S PTR=0 F   S PTR=$O (ORDIALOG( PTR)) Q:PT R'>0  D
  7701   "RTN","VPR CORD3",123 ,0)
  7702    .S NAME=$ P(ORDIALOG (PTR),U,2)  I NAME="C OMMENT" Q
  7703   "RTN","VPR CORD3",124 ,0)
  7704    .S CNT=CN T+1
  7705   "RTN","VPR CORD3",125 ,0)
  7706    .S NUM=0  F  S NUM=$ O(ORDIALOG (PTR,NUM))  Q:+NUM'>0   D
  7707   "RTN","VPR CORD3",126 ,0)
  7708    ..S NODE= OCPKG_U_NA ME_U_TEMP( PTR)
  7709   "RTN","VPR CORD3",127 ,0)
  7710    ..I NAME= "DRUG" S $ P(VPRCHECK (1),U,3)=T EMP(PTR)
  7711   "RTN","VPR CORD3",128 ,0)
  7712    ..I NAME= "SIG" D
  7713   "RTN","VPR CORD3",129 ,0)
  7714    ...S WP=T EMP(PTR)
  7715   "RTN","VPR CORD3",130 ,0)
  7716    ...I '$D( @WP@(1,0))  Q
  7717   "RTN","VPR CORD3",131 ,0)
  7718    ...S NODE =OCPKG_U_N AME_U_1_U_ U_"WP"_U_U _@WP@(1,0)
  7719   "RTN","VPR CORD3",132 ,0)
  7720    ..S VPRCH ECK(CNT)=N ODE
  7721   "RTN","VPR CORD3",133 ,0)
  7722    ;
  7723   "RTN","VPR CORD3",134 ,0)
  7724    Q RESULT
  7725   "RTN","VPR CORD3",135 ,0)
  7726    ;
  7727   "RTN","VPR CORD3",136 ,0)
  7728   ORDDIAL(ER ROR,ORDIAL OG,VALUES, VPRTYPE,OI IEN,PAT,LO C) ;
  7729   "RTN","VPR CORD3",137 ,0)
  7730    I $D(VALU ES("STARTD ATE")) S V ALUES("STA RT DATE/TI ME")=VALUE S("STARTDA TE") K VAL UES("START DATE")
  7731   "RTN","VPR CORD3",138 ,0)
  7732    I $D(VALU ES("PREOPD ATE")) S V ALUES("PRE -OP SCHEDU LED DATE/T IME")=VALU ES("PREOPD ATE") K VA LUES("PREO PDATE")
  7733   "RTN","VPR CORD3",139 ,0)
  7734    I $D(VALU ES("SUBMIT ")) S VALU ES("IMAGIN G LOCATION ")=VALUES( "SUBMIT")  K VALUES(" SUBMIT")
  7735   "RTN","VPR CORD3",140 ,0)
  7736    I $D(VALU ES("TRANSP ORT")) S V ALUES("MOD E OF TRANS PORT")=VAL UES("TRANS PORT") K V ALUES("TRA NSPORT")
  7737   "RTN","VPR CORD3",141 ,0)
  7738    I $D(VALU ES("ISOLAT ION")) S V ALUES("YES /NO")=VALU ES("ISOLAT ION") K VA LUES("ISOL ATION")
  7739   "RTN","VPR CORD3",142 ,0)
  7740    I $D(VALU ES("REASON STUDY")) S  VALUES("S TUDY REASO N")=VALUES ("REASONST UDY") K VA LUES("REAS ONSTUDY")
  7741   "RTN","VPR CORD3",143 ,0)
  7742    I '$D(VAL UES("URGEN CY")) S VA LUES("URGE NCY")=9
  7743   "RTN","VPR CORD3",144 ,0)
  7744    I $D(VALU ES("COMMEN TS")) D
  7745   "RTN","VPR CORD3",145 ,0)
  7746    .S ^TMP(" VPRWORD",$ J,1,0)=VAL UES("COMME NTS")
  7747   "RTN","VPR CORD3",146 ,0)
  7748    .S VALUES ("WORD PRO CESSING 1" )=$NA(^TMP ("VPRWORD" ,$J))
  7749   "RTN","VPR CORD3",147 ,0)
  7750    .K VALUES ("COMMENT" )
  7751   "RTN","VPR CORD3",148 ,0)
  7752    Q 1
  7753   "RTN","VPR CORD3",149 ,0)
  7754    ;
  7755   "RTN","VPR CORD3",150 ,0)
  7756   PS(ERROR,O RDIALOG,VA LUES,VPRTY PE,OIIEN,P AT,LOC) ;
  7757   "RTN","VPR CORD3",151 ,0)
  7758    N ARRAY,C NT,DOSE,DO SENODE,DOS ESTR,DRUG, FAIL,FOUND ,NODE,PRIO RITY,ROUTE ,ROUTEIEN, SCH,TEMP,V AL,VPRLST, VPRPRIOR,V PRROUTE,VP RSCH
  7759   "RTN","VPR CORD3",152 ,0)
  7760    S FAIL=0
  7761   "RTN","VPR CORD3",153 ,0)
  7762    I $D(VALU ES("STARTD ATE")) S V ALUES("STA RT DATE/TI ME")=VALUE S("STARTDA TE") K VAL UES("START DATE")
  7763   "RTN","VPR CORD3",154 ,0)
  7764    D SCHALL^ ORWDPS1(.V PRSCH,PAT, LOC)
  7765   "RTN","VPR CORD3",155 ,0)
  7766    D ODSLCT^ ORWDPS1(.V PRPRIOR,$E (VPRTYPE), PAT,LOC)
  7767   "RTN","VPR CORD3",156 ,0)
  7768    D OISLCT^ ORWDPS2(.V PRLST,OIIE N,$E(VPRTY PE),PAT,"Y ","N")
  7769   "RTN","VPR CORD3",157 ,0)
  7770    D BLDROUT E(.VPRROUT E)
  7771   "RTN","VPR CORD3",158 ,0)
  7772    S VALUES( "INSTRUCTI ONS")=$G(V ALUES("DOS E"))_U_$G( VALUES("DO SE")) K VA LUES("DOSE S")
  7773   "RTN","VPR CORD3",159 ,0)
  7774    ;
  7775   "RTN","VPR CORD3",160 ,0)
  7776   PSROUTE ;s et route
  7777   "RTN","VPR CORD3",161 ,0)
  7778    I '$D(VAL UES("ROUTE ")),VPRTYP E="NV RX"  G PSSCH
  7779   "RTN","VPR CORD3",162 ,0)
  7780    S TEMP=$G (VALUES("R OUTE"))
  7781   "RTN","VPR CORD3",163 ,0)
  7782    S ROUTEIE N=+$G(VPRR OUTE(TEMP) ) I ROUTEI EN<1 D AE^ VPRCORD1(" Could not  find a val id route", .ERROR) S  FAIL=1
  7783   "RTN","VPR CORD3",164 ,0)
  7784    S ROUTE=$ S(VPRTYPE' ["UD":$P(V PRROUTE(VA LUES("ROUT E")),U,2), 1:TEMP)
  7785   "RTN","VPR CORD3",165 ,0)
  7786    I ROUTE=" " S ROUTE= TEMP
  7787   "RTN","VPR CORD3",166 ,0)
  7788    S VALUES( "ROUTE")=R OUTEIEN_U_ TEMP
  7789   "RTN","VPR CORD3",167 ,0)
  7790    ;
  7791   "RTN","VPR CORD3",168 ,0)
  7792   PSURG ;bui ld urgency  value
  7793   "RTN","VPR CORD3",169 ,0)
  7794    S CNT=0,F OUND=0,PRI OR=0 F  S  CNT=$O(VPR PRIOR(CNT) ) Q:CNT'>0 !(FOUND=1)   D
  7795   "RTN","VPR CORD3",170 ,0)
  7796    .S NODE=V PRPRIOR(CN T) I NODE= "~Priority " S PRIOR= 1
  7797   "RTN","VPR CORD3",171 ,0)
  7798    .I PRIOR= 0 Q
  7799   "RTN","VPR CORD3",172 ,0)
  7800    .I $E(NOD E)="~"
  7801   "RTN","VPR CORD3",173 ,0)
  7802    .I $G(VAL UES("URGEN CY"))'=""  D  Q
  7803   "RTN","VPR CORD3",174 ,0)
  7804    ..I $P(NO DE,U,2)'=V ALUES("URG ENCY") Q
  7805   "RTN","VPR CORD3",175 ,0)
  7806    ..S TEMP= $P(NODE,U)  S VALUES( "URGENCY") =$E(TEMP,2 ,$L(TEMP))  S FOUND=1
  7807   "RTN","VPR CORD3",176 ,0)
  7808    .I $E(NOD E)="i" Q
  7809   "RTN","VPR CORD3",177 ,0)
  7810    .S TEMP=$ P(NODE,U)  S VALUES(" URGENCY")= $E(TEMP,2, $L(TEMP))  S FOUND=1
  7811   "RTN","VPR CORD3",178 ,0)
  7812    ;
  7813   "RTN","VPR CORD3",179 ,0)
  7814   PSSCH ;pop ulate addi tional sch edule fiel ds for inp atient med s
  7815   "RTN","VPR CORD3",180 ,0)
  7816    ;TODO mov e to sub-r outine to  handle Day s of Weeks  schedules
  7817   "RTN","VPR CORD3",181 ,0)
  7818    I '$D(VAL UES("SCHED ULE")),VPR TYPE="NV R X" G PSSCO M
  7819   "RTN","VPR CORD3",182 ,0)
  7820    S CNT=0,F OUND=0 F   S CNT=$O(V PRSCH(CNT) ) Q:CNT'>0 !(FOUND=1)   D
  7821   "RTN","VPR CORD3",183 ,0)
  7822    .S NODE=$ G(VPRSCH(C NT)) I $P( NODE,U)'=V ALUES("SCH EDULE") Q
  7823   "RTN","VPR CORD3",184 ,0)
  7824    .S VALUES ("SCHEDULE  TYPE")=$P (NODE,U,3) _U_$P(NODE ,U,3),VALU ES("ADMIN  TIMES")=$P (NODE,U,4) _U_$P(NODE ,U,4),VALU ES("SCHEDU LE")=VALUE S("SCHEDUL E")_U_VALU ES("SCHEDU LE")
  7825   "RTN","VPR CORD3",185 ,0)
  7826    .S SCH=$S (VPRTYPE'[ "UD":$P(NO DE,U,2),1: $P(NODE,U) )
  7827   "RTN","VPR CORD3",186 ,0)
  7828    .S FOUND= 1
  7829   "RTN","VPR CORD3",187 ,0)
  7830    ;
  7831   "RTN","VPR CORD3",188 ,0)
  7832   PSSCOM ;
  7833   "RTN","VPR CORD3",189 ,0)
  7834    I $D(VALU ES("COMMEN TS")) D
  7835   "RTN","VPR CORD3",190 ,0)
  7836    .S ^TMP(" VPRWORD",$ J,1,0)=VAL UES("COMME NTS")
  7837   "RTN","VPR CORD3",191 ,0)
  7838    .S VALUES ("WORD PRO CESSING 1" )=$NA(^TMP ("VPRWORD" ,$J))
  7839   "RTN","VPR CORD3",192 ,0)
  7840    .K VALUES ("COMMENT" )
  7841   "RTN","VPR CORD3",193 ,0)
  7842    ;
  7843   "RTN","VPR CORD3",194 ,0)
  7844   PSDRUG ;po pulate add itional fe lds based  off the do se
  7845   "RTN","VPR CORD3",195 ,0)
  7846    S CNT=0,F OUND=0,DOS ENODE=0 F   S CNT=$O( VPRLST(CNT )) Q:CNT'> 0!(FOUND=1 )  D
  7847   "RTN","VPR CORD3",196 ,0)
  7848    .S NODE=V PRLST(CNT)  I NODE="~ AllDoses"  S DOSENODE =1
  7849   "RTN","VPR CORD3",197 ,0)
  7850    .I DOSENO DE=0 Q
  7851   "RTN","VPR CORD3",198 ,0)
  7852    .I $E(NOD E)="~" Q
  7853   "RTN","VPR CORD3",199 ,0)
  7854    .S DOSE=$ P(NODE,U)  S DOSE=$E( DOSE,2,$L( DOSE))
  7855   "RTN","VPR CORD3",200 ,0)
  7856    .I $P(VAL UES("INSTR UCTIONS"), U)'=DOSE Q
  7857   "RTN","VPR CORD3",201 ,0)
  7858    .S VALUES ("DISPENSE  DRUG")=$P (NODE,U,2)
  7859   "RTN","VPR CORD3",202 ,0)
  7860    .S VALUES ("DOSE")=$ P(NODE,U,3 )
  7861   "RTN","VPR CORD3",203 ,0)
  7862   PSO ;handl e outpatie nt meds
  7863   "RTN","VPR CORD3",204 ,0)
  7864    I $D(VALU ES("SUPPLY ")) D
  7865   "RTN","VPR CORD3",205 ,0)
  7866    .N CNT,DR G,PRIOR,PT R,QUANTITY ,SUP,UPD,X
  7867   "RTN","VPR CORD3",206 ,0)
  7868    .S DRG=$G (VALUES("D ISPENSE DR UG")),SUP= VALUES("SU PPLY")
  7869   "RTN","VPR CORD3",207 ,0)
  7870    .K VALUES ("SUPPLY")
  7871   "RTN","VPR CORD3",208 ,0)
  7872    .;get qua ntity do a  check to  determine  if it is v alid range  or if one  is not de fined
  7873   "RTN","VPR CORD3",209 ,0)
  7874    .;potenti ally need  to add cod e to handl e complex  orders
  7875   "RTN","VPR CORD3",210 ,0)
  7876    .S UPD=$P (VALUES("D OSE"),"&", 3)
  7877   "RTN","VPR CORD3",211 ,0)
  7878    .D DAY2QT Y^ORWDPS2( .VAL,SUP,U PD_U,$P(VA LUES("SCHE DULE"),U)_ U,"~^",PAT ,DRG)
  7879   "RTN","VPR CORD3",212 ,0)
  7880    .S QUANTI TY=+$G(VAL UES("QUANT ITY"))
  7881   "RTN","VPR CORD3",213 ,0)
  7882    .I QUANTI TY=0 S VAL UES("QUANT ITY")=+VAL
  7883   "RTN","VPR CORD3",214 ,0)
  7884    .I QUANTI TY>0 S VAL UES("QUANT ITY")=$S(Q UANTITY<VA L:QUANTITY ,+VAL=0:QU ANTITY,1:V AL)
  7885   "RTN","VPR CORD3",215 ,0)
  7886    .S VALUES ("DAYS SUP PLY")=SUP
  7887   "RTN","VPR CORD3",216 ,0)
  7888    .I +$G(VA LUES("DAYS  SUPPLY")) =0 D AE^VP RCORD1("Da ys Supply  must be gr eater then  zero",.ER ROR) S FAI L=1
  7889   "RTN","VPR CORD3",217 ,0)
  7890    .I +$G(VA LUES("QUAN TITY"))=0  D AE^VPRCO RD1("Quant ity must b e greater  then zero" ,.ERROR) S  FAIL=1
  7891   "RTN","VPR CORD3",218 ,0)
  7892    .;
  7893   "RTN","VPR CORD3",219 ,0)
  7894    .;check r efill valu es to make  sure it i s in range
  7895   "RTN","VPR CORD3",220 ,0)
  7896    .I +$G(VA LUES("REFI LLS"))>0 D
  7897   "RTN","VPR CORD3",221 ,0)
  7898    ..K VAL
  7899   "RTN","VPR CORD3",222 ,0)
  7900    ..D MAXRE F^ORWDPS2( .VAL,PAT,D RG,SUP,OII EN,0)
  7901   "RTN","VPR CORD3",223 ,0)
  7902    ..I VALUE S("REFILLS ")>VAL S V ALUES("REF ILLS")=VAL
  7903   "RTN","VPR CORD3",224 ,0)
  7904    .I +$G(VA LUES("REFI LLS"))=0 S  VALUES("R EFILLS")=0
  7905   "RTN","VPR CORD3",225 ,0)
  7906    .I $D(VAL UES("ROUTI NE")) D
  7907   "RTN","VPR CORD3",226 ,0)
  7908    ..S PTR=$ $PTR("ROUT ING") I PT R'>0 Q
  7909   "RTN","VPR CORD3",227 ,0)
  7910    ..S NODE= $P($G(^ORD (101.41,PT R,1)),U,2)  I NODE=""  Q
  7911   "RTN","VPR CORD3",228 ,0)
  7912    ..S CNT=$ L(NODE,";" )-1
  7913   "RTN","VPR CORD3",229 ,0)
  7914    ..F X=1:1 :CNT D
  7915   "RTN","VPR CORD3",230 ,0)
  7916    ...S TEMP =$P(NODE," ;",X) I TE MP="" Q
  7917   "RTN","VPR CORD3",231 ,0)
  7918    ...S ARRA Y($P(TEMP, ":",2))=$P (TEMP,":")
  7919   "RTN","VPR CORD3",232 ,0)
  7920    ...I $D(A RRAY(VALUE S("ROUTING "))) S VAL UES("ROUTI NG")=ARRAY (VALUES("R OUTING"))
  7921   "RTN","VPR CORD3",233 ,0)
  7922    .;
  7923   "RTN","VPR CORD3",234 ,0)
  7924    .;check f or valid r outing val ue or set  a default  value
  7925   "RTN","VPR CORD3",235 ,0)
  7926    .I '$D(VA LUES("ROUT ING")) D
  7927   "RTN","VPR CORD3",236 ,0)
  7928    ..S CNT=0 ,FOUND=0,P RIOR=0 F   S CNT=$O(V PRPRIOR(CN T)) Q:CNT' >0!(FOUND= 1)  D
  7929   "RTN","VPR CORD3",237 ,0)
  7930    ...S NODE =VPRPRIOR( CNT) I NOD E="~Pickup " S PRIOR= 1
  7931   "RTN","VPR CORD3",238 ,0)
  7932    ...I PRIO R=0 Q
  7933   "RTN","VPR CORD3",239 ,0)
  7934    ...I $E(N ODE)="~" Q
  7935   "RTN","VPR CORD3",240 ,0)
  7936    ...S TEMP =$P(NODE,U ) S VALUES ("ROUTING" )=$E(TEMP, 2,$L(TEMP) ) S FOUND= 1
  7937   "RTN","VPR CORD3",241 ,0)
  7938    ;
  7939   "RTN","VPR CORD3",242 ,0)
  7940    I FAIL>0  Q 0
  7941   "RTN","VPR CORD3",243 ,0)
  7942   PSSIG ;bui ld sig val ue
  7943   "RTN","VPR CORD3",244 ,0)
  7944    N WP
  7945   "RTN","VPR CORD3",245 ,0)
  7946    S ^TMP("V PRSIG",$J, 0,0)=$P(VA LUES("INST RUCTIONS") ,U)
  7947   "RTN","VPR CORD3",246 ,0)
  7948    I $G(ROUT E)'="" S ^ TMP("VPRSI G",$J,1,0) =ROUTE
  7949   "RTN","VPR CORD3",247 ,0)
  7950    I $G(SCH)  S ^TMP("V PRSIG",$J, 1,0)=$S($G (^TMP("VPR SIG",$J,1, 0))'="":^T MP("VPRSIG ",$J,1,0)_ " "_SCH,1: SCH)
  7951   "RTN","VPR CORD3",248 ,0)
  7952    I $D(VALU ES("WORD P ROCESSING  1")) D
  7953   "RTN","VPR CORD3",249 ,0)
  7954    .S WP=VAL UES("WORD  PROCESSING  1")
  7955   "RTN","VPR CORD3",250 ,0)
  7956    .S CNT=1, NUM=1 F  S  CNT=$O(@W P@(CNT)) Q :CNT'>0  D
  7957   "RTN","VPR CORD3",251 ,0)
  7958    ..S NUM=N UM+1 S ^TM P("VPRSIG" ,$J,NUM,0) =@WP@(CNT, 0)
  7959   "RTN","VPR CORD3",252 ,0)
  7960    S VALUES( "SIG")=$NA (^TMP("VPR SIG",$J))
  7961   "RTN","VPR CORD3",253 ,0)
  7962    Q 1
  7963   "RTN","VPR CORD3",254 ,0)
  7964    ;
  7965   "RTN","VPR CORD3",255 ,0)
  7966   QO(ERROR,V ALUES,LOC, PAT,ISIMO, ORD) ;
  7967   "RTN","VPR CORD3",256 ,0)
  7968    N BLDRES, DEFIEN,DIE N,IEN,PKGI D,PKGNAME, VARSARR,VP ROREST,VPR CHECK
  7969   "RTN","VPR CORD3",257 ,0)
  7970    S IEN=+$O (^ORD(101. 41,"B",VAL UES("QO"), "")) I IEN '>0 D AE^V PRCORD1("C ould not f ind QO",.E RROR) Q
  7971   "RTN","VPR CORD3",258 ,0)
  7972    ;
  7973   "RTN","VPR CORD3",259 ,0)
  7974    D BEG^VPR CORD2(PAT, LOC,IEN,US ER,.VARSAR R,.BLDRES, .VPRVALUE)  I $D(ERRO R) Q
  7975   "RTN","VPR CORD3",260 ,0)
  7976    S PKGID=+ $P($G(^ORD (101.41,IE N,0)),U,7)  I PKGID'> 0 D AE^VPR CORD1("Cou ld not fin d package  for the QO ",.ERROR)  Q
  7977   "RTN","VPR CORD3",261 ,0)
  7978    S PKGNAME =$P(^DIC(9 .4,PKGID,0 ),U,2) I P KGNAME=""  D AE^VPRCO RD1("Canno t find pac kage name" ,.VPRVALUE ) Q
  7979   "RTN","VPR CORD3",262 ,0)
  7980    ;
  7981   "RTN","VPR CORD3",263 ,0)
  7982    I $P(BLDR ES(0),U,4) '="Q" D AE ^VPRCORD1( "Item is n ot a QO",. ERROR) Q
  7983   "RTN","VPR CORD3",264 ,0)
  7984    S ORDTYPE ="Q"
  7985   "RTN","VPR CORD3",265 ,0)
  7986    ;I $P(BLD RES(0),U)' =1,$P(BLDR ES(0),U)'= 2 D AE("Qu ick Order  is not set  to Auto-A ccept",.VP RVALUE) S  VPROK=2 Q
  7987   "RTN","VPR CORD3",266 ,0)
  7988    S RSPID=$ P(BLDRES(0 ),U,2)
  7989   "RTN","VPR CORD3",267 ,0)
  7990    S DEFIEN= $$DEFDLG^O RCD(IEN)
  7991   "RTN","VPR CORD3",268 ,0)
  7992    S VARSARR ("DISPLAY  GROUP IEN" )=$P($G(^O RD(101.41, DEFIEN,0)) ,U,5)
  7993   "RTN","VPR CORD3",269 ,0)
  7994    S VARSARR ("DISPLAY  GROUP")=$P ($G(^ORD(1 01.98,VARS ARR("DISPL AY GROUP I EN"),0)),U )
  7995   "RTN","VPR CORD3",270 ,0)
  7996    D BLDORDL G^VPRCORD1 (.ORDIALOG ,IEN,PAT,R SPID,ORDTY PE)
  7997   "RTN","VPR CORD3",271 ,0)
  7998    ;S DIEN=V ARSARR("DI SPLAY GROU P IEN")
  7999   "RTN","VPR CORD3",272 ,0)
  8000    D FILLID^ ORWDXC(.FI LLER,IEN)
  8001   "RTN","VPR CORD3",273 ,0)
  8002    S VARSARR ("FILLER I D")=FILLER
  8003   "RTN","VPR CORD3",274 ,0)
  8004    ;I ORDTYP E="E" S DI EN=+$P($G( ^OR(100,VP ROIFN,0)), U,5)
  8005   "RTN","VPR CORD3",275 ,0)
  8006    ;I ORDTYP E="Q" S DI EN=VPROIFN
  8007   "RTN","VPR CORD3",276 ,0)
  8008    S DLGNAME =$P($G(^OR D(101.41,D EFIEN,0)), U)
  8009   "RTN","VPR CORD3",277 ,0)
  8010    I DLGNAME ="" D AE^V PRCORD1("I NVALID DEF AULT DIALO G",.ERROR)  Q
  8011   "RTN","VPR CORD3",278 ,0)
  8012    S VARSARR ("DIALOG N AME")=DLGN AME
  8013   "RTN","VPR CORD3",279 ,0)
  8014    D DLGDEF^ ORWDX(.DLG DEF,DLGNAM E)
  8015   "RTN","VPR CORD3",280 ,0)
  8016    ;build or der check  array,buil d dialog s tructure a nd build s ave array
  8017   "RTN","VPR CORD3",281 ,0)
  8018    D BLDARRS ^VPRCORD2( .RESULT,.O RDIALOG,.V ARSARR,PAT ,LOC,.VPRC HECK,.SAVE ARR,.VPRPO SS)
  8019   "RTN","VPR CORD3",282 ,0)
  8020    D PERCHCK S(.ERROR,. ORDIALOG,. VPRCHECK,P AT,LOC,USE R,DEFIEN,D LGNAME,VAR SARR("DISP LAY GROUP  IEN"),PKGI D,PKGNAME, IEN,"Q") I  $D(ERROR)  Q
  8021   "RTN","VPR CORD3",283 ,0)
  8022    D SAVE(.V PROREST,PA T,USER,LOC ,DLGNAME,V ARSARR("DI SPLAY GROU P IEN"),0, IEN,.ORDIA LOG,.ORD)
  8023   "RTN","VPR CORD3",284 ,0)
  8024    Q
  8025   "RTN","VPR CORD3",285 ,0)
  8026    ;
  8027   "RTN","VPR CORD3",286 ,0)
  8028   SAVE(VPROR EST,PAT,US ER,LOC,DLG NAME,DGIEN ,ORIFN,QOI EN,SAVEARR ,ORD) ;
  8029   "RTN","VPR CORD3",287 ,0)
  8030    ;SAVE(REC ,ORVP,ORNP ,ORL,DLG,O RDG,ORIT,O RIFN,ORDIA LOG,ORDEA, ORAPPT,ORS RC,OREVTDF )
  8031   "RTN","VPR CORD3",288 ,0)
  8032    I QOIEN>0  D SAVE^OR WDX(.VPROR EST,PAT,US ER,LOC,DLG NAME,DGIEN ,QOIEN,"", .SAVEARR," ",DT,"",0)
  8033   "RTN","VPR CORD3",289 ,0)
  8034    I ORIFN>0  D SAVE^OR WDX(.VPROR EST,PAT,US ER,LOC,DLG NAME,DGIEN ,"","",.SA VEARR,"",D T,"",0)
  8035   "RTN","VPR CORD3",290 ,0)
  8036    N CNT,DFN ,IEN
  8037   "RTN","VPR CORD3",291 ,0)
  8038    S CNT=0,I EN=0 F  S  CNT=$O(VPR OREST(CNT) ) Q:CNT'>0 !(IEN>0)   D
  8039   "RTN","VPR CORD3",292 ,0)
  8040    .I $E(VPR OREST(CNT) )="~" S IE N=+$P($P(V PROREST(CN T),U),"~", 2)
  8041   "RTN","VPR CORD3",293 ,0)
  8042    I IEN>0 S  DFN=PAT D  ORX^VPRDJ 01(IEN,.OR D)
  8043   "RTN","VPR CORD3",294 ,0)
  8044    Q
  8045   "RTN","VPR CORD3",295 ,0)
  8046    ;
  8047   "RTN","VPR CORD3",296 ,0)
  8048   VALIDOI(VA LUES,TYPE)  ;
  8049   "RTN","VPR CORD3",297 ,0)
  8050    N IEN,POS SOI
  8051   "RTN","VPR CORD3",298 ,0)
  8052    S IEN=$P( VALUES("OI "),":",5)  I IEN'>0 Q  -1
  8053   "RTN","VPR CORD3",299 ,0)
  8054    ;S IEN=$P (VALUES("O I"),":",5)  I IEN'>0  Q -1
  8055   "RTN","VPR CORD3",300 ,0)
  8056    S POSSOI= $P(^ORD(10 1.43,IEN,0 ),U)
  8057   "RTN","VPR CORD3",301 ,0)
  8058    S VALUES( "OI")=POSS OI
  8059   "RTN","VPR CORD3",302 ,0)
  8060    ;S SETTYP E=$$GETSET (TYPE) I S ETTYPE=""  Q -1
  8061   "RTN","VPR CORD3",303 ,0)
  8062    S RESULT= $O(^ORD(10 1.43,"S."_ TYPE,POSSO I,""))
  8063   "RTN","VPR CORD3",304 ,0)
  8064    Q RESULT
  8065   "RTN","VPR CORD3",305 ,0)
  8066    ;
  8067   "RTN","VPR CORD3",306 ,0)
  8068   PTR(NAME)  ;
  8069   "RTN","VPR CORD3",307 ,0)
  8070    Q $O(^ORD (101.41,"B ","OR GTX  "_NAME,"") )
  8071   "RTN","VPR CORD4")
  8072   0^46^B1401 28091
  8073   "RTN","VPR CORD4",1,0 )
  8074   VPRCORD4 ; ;SLC/AGP - Retreived  Orderable  Items ; 1/ 4/13
  8075   "RTN","VPR CORD4",2,0 )
  8076    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  8077   "RTN","VPR CORD4",3,0 )
  8078    ;
  8079   "RTN","VPR CORD4",4,0 )
  8080    ;
  8081   "RTN","VPR CORD4",5,0 )
  8082    Q
  8083   "RTN","VPR CORD4",6,0 )
  8084    ;
  8085   "RTN","VPR CORD4",7,0 )
  8086   ADDODG ;
  8087   "RTN","VPR CORD4",8,0 )
  8088    N CNT,IEN ,NUM,NODE, PTR,RESULT ,TEMP
  8089   "RTN","VPR CORD4",9,0 )
  8090    N ERRMSG  S ERRMSG=" A mumps er ror occurr ed while e xtaracting  display g roups"
  8091   "RTN","VPR CORD4",10, 0)
  8092    S IEN=0 F   S IEN=$O (^ORD(100. 98,IEN)) Q :IEN'>0  D
  8093   "RTN","VPR CORD4",11, 0)
  8094    .N $ES,$E T
  8095   "RTN","VPR CORD4",12, 0)
  8096    .S $ET="D  ERRHDLR^V PRDERRH"
  8097   "RTN","VPR CORD4",13, 0)
  8098    .I '$D(^O RD(100.98, IEN,1)) D   Q
  8099   "RTN","VPR CORD4",14, 0)
  8100    ..S NODE= $G(^ORD(10 0.98,IEN,0 )) D SODGN ODE(.RESUL T,NODE)
  8101   "RTN","VPR CORD4",15, 0)
  8102    ..S RESUL T("uid")=$ $SETUID^VP RUTILS("di splayGroup ","",IEN), RESULT("in ternal")=I EN
  8103   "RTN","VPR CORD4",16, 0)
  8104    ..D ADD^V PREF("RESU LT") S VPR CNT=+$G(VP RCNT)+1,VP RLAST=IEN
  8105   "RTN","VPR CORD4",17, 0)
  8106    .D ADDODG 1(IEN,.TEM P)
  8107   "RTN","VPR CORD4",18, 0)
  8108    .M RESULT =TEMP
  8109   "RTN","VPR CORD4",19, 0)
  8110    .D ADD^VP REF("RESUL T") S VPRC NT=+$G(VPR CNT)+1,VPR LAST=IEN
  8111   "RTN","VPR CORD4",20, 0)
  8112    I IEN'>0  S VPRFINI= 1
  8113   "RTN","VPR CORD4",21, 0)
  8114    Q
  8115   "RTN","VPR CORD4",22, 0)
  8116    ;
  8117   "RTN","VPR CORD4",23, 0)
  8118   ADDODG1(IE N,TEMP) ;
  8119   "RTN","VPR CORD4",24, 0)
  8120    N CNT,NOD E,NUM,PTR
  8121   "RTN","VPR CORD4",25, 0)
  8122    S NODE=$G (^ORD(100. 98,IEN,0))  D SODGNOD E(.TEMP,NO DE)
  8123   "RTN","VPR CORD4",26, 0)
  8124    S TEMP("u id")=$$SET UID^VPRUTI LS("displa yGroup","" ,IEN),TEMP ("internal ")=IEN
  8125   "RTN","VPR CORD4",27, 0)
  8126    I '$D(^OR D(100.98,I EN,1)) Q
  8127   "RTN","VPR CORD4",28, 0)
  8128    S NUM=0,C NT=0 F  S  NUM=$O(^OR D(100.98,I EN,1,NUM))  Q:NUM'>0   D
  8129   "RTN","VPR CORD4",29, 0)
  8130    .N ARRAY
  8131   "RTN","VPR CORD4",30, 0)
  8132    .S PTR=$G (^ORD(100. 98,IEN,1,N UM,0)) Q:P TR'>0
  8133   "RTN","VPR CORD4",31, 0)
  8134    .D ADDODG 1(PTR,.ARR AY) I '$D( ARRAY) Q
  8135   "RTN","VPR CORD4",32, 0)
  8136    .S CNT=CN T+1 M TEMP ("children ",CNT,"ite m")=ARRAY
  8137   "RTN","VPR CORD4",33, 0)
  8138    Q
  8139   "RTN","VPR CORD4",34, 0)
  8140    ;
  8141   "RTN","VPR CORD4",35, 0)
  8142   SODGNODE(R ESULT,NODE ) ;
  8143   "RTN","VPR CORD4",36, 0)
  8144    N NAME,TE MP,X
  8145   "RTN","VPR CORD4",37, 0)
  8146    F X=1:1:4  D
  8147   "RTN","VPR CORD4",38, 0)
  8148    .S TEMP=$ P(NODE,U,X ) I X<4,$L (TEMP)>1 S  RESULT($S (X=1:"name ",X=2:"dis playName", X=3:"abbre viation")) =TEMP
  8149   "RTN","VPR CORD4",39, 0)
  8150    .I X=4,+T EMP>0 S NA ME=$P($G(^ ORD(101.41 ,TEMP,0)), U) S RESUL T("default DialogUid" )=$$SETUID ^VPRUTILS( "orderDial og","",TEM P),RESULT( "defaultDi alogName") =NAME
  8151   "RTN","VPR CORD4",40, 0)
  8152    Q
  8153   "RTN","VPR CORD4",41, 0)
  8154    ;
  8155   "RTN","VPR CORD4",42, 0)
  8156   ADDROUTE ;
  8157   "RTN","VPR CORD4",43, 0)
  8158    N CNT,IEN ,NAME,RESU LT,ROUTES, X,UID,VALU E
  8159   "RTN","VPR CORD4",44, 0)
  8160    N ERRMSG
  8161   "RTN","VPR CORD4",45, 0)
  8162    S ERRMSG= "A mumps e rror occur red while  extaractin g routes."
  8163   "RTN","VPR CORD4",46, 0)
  8164    S CNT=1,I EN=0
  8165   "RTN","VPR CORD4",47, 0)
  8166    I +$G(VPR LAST)>0 S  IEN=VPRLAS T
  8167   "RTN","VPR CORD4",48, 0)
  8168    F  S IEN= $O(^PS(51. 2,IEN)) Q: IEN'>0  D
  8169   "RTN","VPR CORD4",49, 0)
  8170    .N $ES,$E T
  8171   "RTN","VPR CORD4",50, 0)
  8172    .S $ET="D  ERRHDLR^V PRDERRH"
  8173   "RTN","VPR CORD4",51, 0)
  8174    .S NODE=$ P($G(^PS(5 1.2,IEN,0) ),U,1,6)
  8175   "RTN","VPR CORD4",52, 0)
  8176    .I $P(NOD E,U,5)>0 Q
  8177   "RTN","VPR CORD4",53, 0)
  8178    .S UID=$$ SETUID^VPR UTILS("rou te","",IEN )
  8179   "RTN","VPR CORD4",54, 0)
  8180    .S RESULT ("uid")=UI D,RESULT(" internal") =IEN
  8181   "RTN","VPR CORD4",55, 0)
  8182    .F X=1,2, 3,6 D
  8183   "RTN","VPR CORD4",56, 0)
  8184    ..S VALUE =$P(NODE,U ,X) Q:VALU E=""
  8185   "RTN","VPR CORD4",57, 0)
  8186    ..S NAME= $S(X=1:"na me",X=2:"e xternalNam e",X=3:"ab breviation ",X=6:"use InIV",1:"" )
  8187   "RTN","VPR CORD4",58, 0)
  8188    ..I NAME= "" Q
  8189   "RTN","VPR CORD4",59, 0)
  8190    ..I X=6 S  VALUE=$S( VALUE=1:"t rue",1:"fa lse")
  8191   "RTN","VPR CORD4",60, 0)
  8192    ..S RESUL T(NAME)=VA LUE
  8193   "RTN","VPR CORD4",61, 0)
  8194    .D ADD^VP REF("RESUL T") S VPRC NT=+$G(VPR CNT)+1,VPR LAST=IEN
  8195   "RTN","VPR CORD4",62, 0)
  8196    .;S CNT=C NT+1
  8197   "RTN","VPR CORD4",63, 0)
  8198    .K RESULT
  8199   "RTN","VPR CORD4",64, 0)
  8200    I IEN'>0  S VPRFINI= 1
  8201   "RTN","VPR CORD4",65, 0)
  8202    Q
  8203   "RTN","VPR CORD4",66, 0)
  8204    ;
  8205   "RTN","VPR CORD4",67, 0)
  8206   ADDSCH ;
  8207   "RTN","VPR CORD4",68, 0)
  8208    N CNT,IEN ,NAME,NODE ,NUM,RESUL T,UID,VPRS CH
  8209   "RTN","VPR CORD4",69, 0)
  8210    ;D SCHALL ^ORWDPS1(. VPRSCH,0,0 )
  8211   "RTN","VPR CORD4",70, 0)
  8212    D SCHED^P SS51P1(0,. VPRSCH)
  8213   "RTN","VPR CORD4",71, 0)
  8214    N ERRMSG
  8215   "RTN","VPR CORD4",72, 0)
  8216    S ERRMSG= "A mumps e rror occur red while  extaractin g schedule s."
  8217   "RTN","VPR CORD4",73, 0)
  8218    S CNT=0 F   S CNT=$O (VPRSCH(CN T)) Q:CNT' >0  D
  8219   "RTN","VPR CORD4",74, 0)
  8220    .N $ES,$E T
  8221   "RTN","VPR CORD4",75, 0)
  8222    .S $ET="D  ERRHDLR^V PRDERRH"
  8223   "RTN","VPR CORD4",76, 0)
  8224    .S NODE=$ G(VPRSCH(C NT))
  8225   "RTN","VPR CORD4",77, 0)
  8226    .S NAME=$ P(NODE,U,2 )
  8227   "RTN","VPR CORD4",78, 0)
  8228    .S IEN=$P (NODE,U)
  8229   "RTN","VPR CORD4",79, 0)
  8230    .;S IEN=$ O(^PS(51.1 ,"B",NAME, "")) I IEN '>0 Q
  8231   "RTN","VPR CORD4",80, 0)
  8232    .S UID=$$ SETUID^VPR UTILS("sch edule","", IEN)
  8233   "RTN","VPR CORD4",81, 0)
  8234    .S RESULT ("uid")=UI D,RESULT(" internal") =IEN
  8235   "RTN","VPR CORD4",82, 0)
  8236    .S RESULT ("name")=N AME
  8237   "RTN","VPR CORD4",83, 0)
  8238    .I $P(NOD E,U,3)'=""  S RESULT( "externalV alue")=$P( NODE,U,3)
  8239   "RTN","VPR CORD4",84, 0)
  8240    .I $P(NOD E,U,4)'=""  S RESULT( "scheduleT ype")=$P(N ODE,U,4)
  8241   "RTN","VPR CORD4",85, 0)
  8242    .D ADD^VP REF("RESUL T") S VPRC NT=+$G(VPR CNT)+1,VPR LAST=IEN
  8243   "RTN","VPR CORD4",86, 0)
  8244    .K RESULT
  8245   "RTN","VPR CORD4",87, 0)
  8246    I CNT'>0  S VPRFINI= 1
  8247   "RTN","VPR CORD4",88, 0)
  8248    Q
  8249   "RTN","VPR CORD4",89, 0)
  8250    ;
  8251   "RTN","VPR CORD4",90, 0)
  8252   LAB(RESULT ,OI) ;
  8253   "RTN","VPR CORD4",91, 0)
  8254    N CNT,I,I EN,NODE,SY N,TEMP,VPR LST
  8255   "RTN","VPR CORD4",92, 0)
  8256    S RESULT( "dialogAdd itionalInf ormation", "sendPatie ntTimes",1 ,"internal ")="LT",RE SULT("dial ogAddition alInformat ion","send PatientTim es",1,"nam e")="Today "
  8257   "RTN","VPR CORD4",93, 0)
  8258    S RESULT( "dialogAdd itionalInf ormation", "sendPatie ntTimes",2 ,"internal ")="LT+1", RESULT("di alogAdditi onalInform ation","se ndPatientT imes",2,"n ame")="Tom orrow"
  8259   "RTN","VPR CORD4",94, 0)
  8260    ;
  8261   "RTN","VPR CORD4",95, 0)
  8262    D GETLST^ XPAR(.VPRL ST,"ALL"," ORWD COMMO N LAB INPT ")  ;DBIA  2263
  8263   "RTN","VPR CORD4",96, 0)
  8264    S I=0 F   S I=$O(VPR LST(I)) Q: 'I  D
  8265   "RTN","VPR CORD4",97, 0)
  8266    . S IEN=$ P(VPRLST(I ),U,2)
  8267   "RTN","VPR CORD4",98, 0)
  8268    . S P1="d ialogAddit ionalInfor mation"
  8269   "RTN","VPR CORD4",99, 0)
  8270    . S RESUL T("dialogA dditionalI nformation ","common" ,I,"uid")= $$SETUID^V PRUTILS("o rderable", "",IEN)
  8271   "RTN","VPR CORD4",100 ,0)
  8272    . S RESUL T("dialogA dditionalI nformation ","common" ,I,"intern al")=IEN
  8273   "RTN","VPR CORD4",101 ,0)
  8274    . S RESUL T("dialogA dditionalI nformation ","common" ,I,"name") =$P(^ORD(1 01.43,IEN, 0),U,1)
  8275   "RTN","VPR CORD4",102 ,0)
  8276    ;
  8277   "RTN","VPR CORD4",103 ,0)
  8278    S NODE=$G (^ORD(101. 43,OI,"LR" ))
  8279   "RTN","VPR CORD4",104 ,0)
  8280    S RESULT( "labDetail s","specim an")=$P(NO DE,U),RESU LT("labDet ails","lab Collect")= $S($P(NODE ,U,2)=1:"t rue",1:"fa lse"),RESU LT("labDet ails","seq uence")=$P (NODE,U,3)
  8281   "RTN","VPR CORD4",105 ,0)
  8282    S RESULT( "labDetail s","maxOrd erFrequenc y")=$P(NOD E,U,4),RES ULT("labDe tails","da ilyOrderMa x")=$P(NOD E,U,5)
  8283   "RTN","VPR CORD4",106 ,0)
  8284    ;
  8285   "RTN","VPR CORD4",107 ,0)
  8286    S TEMP=$P (NODE,U,6)
  8287   "RTN","VPR CORD4",108 ,0)
  8288    S RESULT( "types",1, "abb")=TEM P,RESULT(" types",1," uid")=$$SE TUID^VPRUT ILS("labTy pe","",TEM P),RESULT( "types",1, "internal" )=TEMP,RES ULT("types ",1,"type" )=$$LABTYP E(TEMP)
  8289   "RTN","VPR CORD4",109 ,0)
  8290    S TEMP=$P (NODE,U,7)
  8291   "RTN","VPR CORD4",110 ,0)
  8292    I TEMP'=" " S RESULT ("labDetai ls","labTy peInternal ")=TEMP,RE SULT("labD etails","l abTypeName ")=$S(TEMP ="I":"Inpu t",TEMP="O ":"Output" ,TEMP="B": "Both",TEM P="N":"Nei ther")
  8293   "RTN","VPR CORD4",111 ,0)
  8294    I '$D(^OR D(101.43,O I,2)) Q
  8295   "RTN","VPR CORD4",112 ,0)
  8296    S CNT=0
  8297   "RTN","VPR CORD4",113 ,0)
  8298    S I=0 F   S I=$O(^OR D(101.43,O I,2,I)) Q: I'>0  D
  8299   "RTN","VPR CORD4",114 ,0)
  8300    .S SYN=$G (^ORD(101. 43,OI,2,I, 0)) Q:SYN= ""
  8301   "RTN","VPR CORD4",115 ,0)
  8302    .S CNT=CN T+1,RESULT ("synonym" ,CNT,"name ")=SYN
  8303   "RTN","VPR CORD4",116 ,0)
  8304    Q
  8305   "RTN","VPR CORD4",117 ,0)
  8306    ;
  8307   "RTN","VPR CORD4",118 ,0)
  8308   LABTYPE(L)  ;
  8309   "RTN","VPR CORD4",119 ,0)
  8310    I L="CH"  Q "Chemist ry"
  8311   "RTN","VPR CORD4",120 ,0)
  8312    I L="MI"  Q "MICROBI OLOGY"
  8313   "RTN","VPR CORD4",121 ,0)
  8314    I L="BB"  Q "Blood B ank"
  8315   "RTN","VPR CORD4",122 ,0)
  8316    I L="EM"  Q "Electro n Microsco py"
  8317   "RTN","VPR CORD4",123 ,0)
  8318    I L="SP"  Q "Surgica l Patholog y"
  8319   "RTN","VPR CORD4",124 ,0)
  8320    I L="AU"  Q "Autopsy "
  8321   "RTN","VPR CORD4",125 ,0)
  8322    I L="CY"  Q "Cytolog y"
  8323   "RTN","VPR CORD4",126 ,0)
  8324    Q ""
  8325   "RTN","VPR CORD4",127 ,0)
  8326    ;
  8327   "RTN","VPR CORD4",128 ,0)
  8328   OI(OITYPE)  ;
  8329   "RTN","VPR CORD4",129 ,0)
  8330    N CNT,ERR OR,IEN,NAM E,LINK,LIN KTYPE,NODE ,RADDET,RA DTYPE,RESU LT,TCNT,TY PE,UID,VPR TEMP
  8331   "RTN","VPR CORD4",130 ,0)
  8332    N ERRMSG
  8333   "RTN","VPR CORD4",131 ,0)
  8334    S ERRMSG= "A mumps e rror occur red while  extaractin g orderabl e items."
  8335   "RTN","VPR CORD4",132 ,0)
  8336    S CNT=1,I EN=0
  8337   "RTN","VPR CORD4",133 ,0)
  8338    ;
  8339   "RTN","VPR CORD4",134 ,0)
  8340    D RADTYPE (.RADTYPE, .RADDET)
  8341   "RTN","VPR CORD4",135 ,0)
  8342    I +$G(VPR LAST)>0 S  IEN=VPRLAS T
  8343   "RTN","VPR CORD4",136 ,0)
  8344    I +$G(VPR ID)>0 S IE N=VPRID
  8345   "RTN","VPR CORD4",137 ,0)
  8346    F  S IEN= $O(^ORD(10 1.43,IEN))  Q:IEN'>0   D  I VPRM AX>0,VPRI' <VPRMAX Q
  8347   "RTN","VPR CORD4",138 ,0)
  8348    .N $ES,$E T
  8349   "RTN","VPR CORD4",139 ,0)
  8350    .S $ET="D  ERRHDLR^V PRDERRH"
  8351   "RTN","VPR CORD4",140 ,0)
  8352    .K RESULT
  8353   "RTN","VPR CORD4",141 ,0)
  8354    .S TYPE=$ $VALIDOI(O ITYPE,IEN)
  8355   "RTN","VPR CORD4",142 ,0)
  8356    .I TYPE=" " Q
  8357   "RTN","VPR CORD4",143 ,0)
  8358    .S NAME=$ P(^ORD(101 .43,IEN,0) ,U),LINK=$ P($P(^ORD( 101.43,IEN ,0),U,2)," ;99",1),LI NKTYPE=$P( $P(^ORD(10 1.43,IEN,0 ),U,2),";9 9",2)
  8359   "RTN","VPR CORD4",144 ,0)
  8360    .S UID=$$ SETUID^VPR UTILS("ord erable","" ,IEN)
  8361   "RTN","VPR CORD4",145 ,0)
  8362    .S RESULT ("uid")=UI D,RESULT(" internal") =IEN
  8363   "RTN","VPR CORD4",146 ,0)
  8364    .S RESULT ("name")=N AME
  8365   "RTN","VPR CORD4",147 ,0)
  8366    .S RESULT ("link")=L INK
  8367   "RTN","VPR CORD4",148 ,0)
  8368    .S RESULT ("linktype ")=LINKTYP E
  8369   "RTN","VPR CORD4",149 ,0)
  8370    .I TYPE[" PS" D PS(. RESULT,IEN ,CNT)
  8371   "RTN","VPR CORD4",150 ,0)
  8372    .I TYPE[" RA" D RA(. RESULT,IEN ,CNT,.RADT YPE,.RADDE T)
  8373   "RTN","VPR CORD4",151 ,0)
  8374    .I TYPE[" LR" D LAB( .RESULT,IE N)
  8375   "RTN","VPR CORD4",152 ,0)
  8376    .D ADD^VP REF("RESUL T") S VPRC NT=+$G(VPR CNT)+1,VPR LAST=IEN
  8377   "RTN","VPR CORD4",153 ,0)
  8378    .S CNT=CN T+1
  8379   "RTN","VPR CORD4",154 ,0)
  8380    I IEN'>0  S VPRFINI= 1
  8381   "RTN","VPR CORD4",155 ,0)
  8382    Q
  8383   "RTN","VPR CORD4",156 ,0)
  8384    ;
  8385   "RTN","VPR CORD4",157 ,0)
  8386   PS(RESULT, IEN,PLACE)  ;
  8387   "RTN","VPR CORD4",158 ,0)
  8388    N CNT,COS T,DOSE,DOS ES,DRUG,ME DS,NAME,NO DE,NUM,PSO I,SIZE,TYP E,UID,VPRD OSE
  8389   "RTN","VPR CORD4",159 ,0)
  8390    S CNT=0
  8391   "RTN","VPR CORD4",160 ,0)
  8392    I $D(^ORD (101.43,IE N,9,"B","N V RX")) S  CNT=CNT+1  S RESULT(" types",CNT ,"type")=" NON-VA MED S" S MEDS( "NV RX")=" "
  8393   "RTN","VPR CORD4",161 ,0)
  8394    I $D(^ORD (101.43,IE N,9,"B","O  RX")) S C NT=CNT+1 S  RESULT("t ypes",CNT, "type")="O UTPATIENT  MEDS" S ME DS("O RX") =""
  8395   "RTN","VPR CORD4",162 ,0)
  8396    I $D(^ORD (101.43,IE N,9,"B","R X")) S CNT =CNT+1 S R ESULT("typ es",CNT,"t ype")="MED S" S MEDS( "RX")=""
  8397   "RTN","VPR CORD4",163 ,0)
  8398    I $D(^ORD (101.43,IE N,9,"B","U D RX")) S  CNT=CNT+1  S RESULT(" types",CNT ,"type")=" INPATIENT  MEDS" S ME DS("UD RX" )=""
  8399   "RTN","VPR CORD4",164 ,0)
  8400    ;
  8401   "RTN","VPR CORD4",165 ,0)
  8402    ;K DOSES
  8403   "RTN","VPR CORD4",166 ,0)
  8404    S PSOI=+$ P(^ORD(101 .43,IEN,0) ,U,2)
  8405   "RTN","VPR CORD4",167 ,0)
  8406    S TYPE=""  F  S TYPE =$O(MEDS(T YPE)) Q:TY PE=""  D
  8407   "RTN","VPR CORD4",168 ,0)
  8408    .D DOSE^P SSOPKI1(.V PRDOSE,PSO I,TYPE,0)
  8409   "RTN","VPR CORD4",169 ,0)
  8410    .S CNT=0  F  S CNT=$ O(VPRDOSE( CNT)) Q:CN T'>0  D
  8411   "RTN","VPR CORD4",170 ,0)
  8412    ..S NODE= $G(VPRDOSE (CNT)),SIZ E="",UID=0 ,DRUG="",C OST=""
  8413   "RTN","VPR CORD4",171 ,0)
  8414    ..S DOSE= $P(NODE,U, 5)
  8415   "RTN","VPR CORD4",172 ,0)
  8416    ..I $D(DO SES(DOSE))  Q
  8417   "RTN","VPR CORD4",173 ,0)
  8418    ..I $P(NO DE,U,3)'=" ",$P(NODE, U,4)'="" S  SIZE=$P(N ODE,U,3)_"  "_$P(NODE ,U,4)
  8419   "RTN","VPR CORD4",174 ,0)
  8420    ..S DRUG= $P(NODE,U, 6),COST=$P (NODE,U,7)
  8421   "RTN","VPR CORD4",175 ,0)
  8422    ..S DOSES (DOSE)=$G( SIZE)_U_DR UG_U_COST
  8423   "RTN","VPR CORD4",176 ,0)
  8424    ;
  8425   "RTN","VPR CORD4",177 ,0)
  8426    S DOSE="" ,CNT=1 F   S DOSE=$O( DOSES(DOSE )) Q:DOSE= ""  D
  8427   "RTN","VPR CORD4",178 ,0)
  8428    .S NODE=D OSES(DOSE)
  8429   "RTN","VPR CORD4",179 ,0)
  8430    .S RESULT ("possible Dosages",C NT,"dose") =DOSE
  8431   "RTN","VPR CORD4",180 ,0)
  8432    .I $P(NOD E,U)'="" S  RESULT("p ossibleDos ages",CNT, "size")=$P (NODE,U)
  8433   "RTN","VPR CORD4",181 ,0)
  8434    .I $P(NOD E,U,2)>0 D
  8435   "RTN","VPR CORD4",182 ,0)
  8436    ..S NAME= $P($G(^PSD RUG($P(NOD E,U,2),0)) ,U)
  8437   "RTN","VPR CORD4",183 ,0)
  8438    ..S RESUL T("possibl eDosages", CNT,"drugU id")=$$SET UID^VPRUTI LS("drug", "",$P(NODE ,U,2))
  8439   "RTN","VPR CORD4",184 ,0)
  8440    ..S RESUL T("possibl eDosages", CNT,"drugI nternal")= $P(NODE,U, 2)
  8441   "RTN","VPR CORD4",185 ,0)
  8442    ..S RESUL T("possibl eDosages", CNT,"drugN ame")=NAME
  8443   "RTN","VPR CORD4",186 ,0)
  8444    .;I $P(NO DE,U,3)'=" " S RESULT ("possible Dosages",C NT,"cost") =$P(NODE,U ,3) 
  8445   "RTN","VPR CORD4",187 ,0)
  8446    .S CNT=CN T+1
  8447   "RTN","VPR CORD4",188 ,0)
  8448    Q
  8449   "RTN","VPR CORD4",189 ,0)
  8450    ;
  8451   "RTN","VPR CORD4",190 ,0)
  8452   RA(RESULT, IEN,PLACE, RADTYPE,RA DDET) ;
  8453   "RTN","VPR CORD4",191 ,0)
  8454    N CNT,NOD E,TEMP
  8455   "RTN","VPR CORD4",192 ,0)
  8456    S CNT=0
  8457   "RTN","VPR CORD4",193 ,0)
  8458    S NODE=$G (^ORD(101. 43,IEN,0))
  8459   "RTN","VPR CORD4",194 ,0)
  8460    I $P(NODE ,U,3)'="", $P(NODE,U, 4)'="" S R ESULT("cod e")=$$SETU ID^VPRUTIL S($$LOW^XL FSTR($P(NO DE,U,4))," ",$P(NODE, U,3))
  8461   "RTN","VPR CORD4",195 ,0)
  8462    S NODE=$G (^ORD(101. 43,IEN,"RA "))
  8463   "RTN","VPR CORD4",196 ,0)
  8464    S RESULT( "imagingDe tails","co ntractMedi a")=$P(NOD E,U)
  8465   "RTN","VPR CORD4",197 ,0)
  8466    I $P(NODE ,U,2)'=""  S TEMP=$P( NODE,U,2), RESULT("im agingDetai ls","proce dureType") =$S(TEMP=" B":"Board" ,TEMP="D": "Detailed" ,TEMP="S": "Series",T EMP="P":"P arent")
  8467   "RTN","VPR CORD4",198 ,0)
  8468    I $D(RADT YPE($P(NOD E,U,3))) D
  8469   "RTN","VPR CORD4",199 ,0)
  8470    .S TEMP=$ G(RADTYPE( $P(NODE,U, 3))),RESUL T("types", 1,"type")= $P(TEMP,U, 2),RESULT( "types",1, "uid")=$$S ETUID^VPRU TILS("radT ype","",$P (TEMP,U)), RESULT("in ternal")=$ P(TEMP,U), RESULT("ty pes",1,"ab b")=$P(NOD E,U,3)
  8471   "RTN","VPR CORD4",200 ,0)
  8472    .S RESULT ("imagingD etails","c ommonProce dure")=$S( $P(NODE,U, 4)=1:"true ",1:"false ")
  8473   "RTN","VPR CORD4",201 ,0)
  8474    .I $D(RAD TYPE($P(NO DE,U,3)))  M RESULT(" dialogAddi tionalInfo rmation")= RADDET($P( NODE,U,3))
  8475   "RTN","VPR CORD4",202 ,0)
  8476    Q
  8477   "RTN","VPR CORD4",203 ,0)
  8478    ;
  8479   "RTN","VPR CORD4",204 ,0)
  8480   RADTYPE(RA DTYPE,RADD ET) ;
  8481   "RTN","VPR CORD4",205 ,0)
  8482    ;build ra diology ty pe array f or reused  to load im aging type s
  8483   "RTN","VPR CORD4",206 ,0)
  8484    N ABB,CNT ,IMGTYP,SU BMIT,TCNT, URG,VALUES ,VPRTEMP,V PRX
  8485   "RTN","VPR CORD4",207 ,0)
  8486    D IMTYPSE L^ORWDRA32 (.VPRTEMP, "")
  8487   "RTN","VPR CORD4",208 ,0)
  8488    D CAT(.VA LUES),TRAN S(.VALUES) ,URGENCY(. VALUES)
  8489   "RTN","VPR CORD4",209 ,0)
  8490    S TCNT=""
  8491   "RTN","VPR CORD4",210 ,0)
  8492    F  S TCNT =$O(VPRTEM P(TCNT)) Q :TCNT=""   D
  8493   "RTN","VPR CORD4",211 ,0)
  8494    .S NODE=V PRTEMP(TCN T)
  8495   "RTN","VPR CORD4",212 ,0)
  8496    .S IMGTYP =$P(NODE,U ),ABB=$P(N ODE,U,3)
  8497   "RTN","VPR CORD4",213 ,0)
  8498    .D SUBMIT (.VALUES,A BB)
  8499   "RTN","VPR CORD4",214 ,0)
  8500    .S RADTYP E(ABB)=IMG TYP_U_$P(N ODE,U,2)_U _$P(NODE,U ,4)
  8501   "RTN","VPR CORD4",215 ,0)
  8502    .I $D(VAL UES) M RAD DET(ABB)=V ALUES
  8503   "RTN","VPR CORD4",216 ,0)
  8504    .;Radiolo gy Modifie r
  8505   "RTN","VPR CORD4",217 ,0)
  8506    .S I=$O(^ RA(79.2,"C ",ABB,0))  Q:'I
  8507   "RTN","VPR CORD4",218 ,0)
  8508    .S VPRX=0 ,CNT=0 F   S VPRX=$O( ^RAMIS(71. 2,"AB",I,V PRX)) Q:'V PRX  D
  8509   "RTN","VPR CORD4",219 ,0)
  8510    ..S CNT=C NT+1
  8511   "RTN","VPR CORD4",220 ,0)
  8512    ..S RADDE T(ABB,"mod ifier",CNT ,"uid")=$$ SETUID^VPR UTILS("mod ifier","", VPRX),RADD ET(ABB,"mo difier",CN T,"interna l")=VPRX
  8513   "RTN","VPR CORD4",221 ,0)
  8514    ..S RADDE T(ABB,"mod ifier",CNT ,"name")=$ P(^RAMIS(7 1.2,VPRX,0 ),U)
  8515   "RTN","VPR CORD4",222 ,0)
  8516    Q
  8517   "RTN","VPR CORD4",223 ,0)
  8518    ;
  8519   "RTN","VPR CORD4",224 ,0)
  8520    ;Transpor t values
  8521   "RTN","VPR CORD4",225 ,0)
  8522   TRANS(RADD ET) ;
  8523   "RTN","VPR CORD4",226 ,0)
  8524    N CNT,VPR X
  8525   "RTN","VPR CORD4",227 ,0)
  8526    S CNT=0
  8527   "RTN","VPR CORD4",228 ,0)
  8528    F VPRX="A ^AMBULATOR Y","P^PORT ABLE","S^S TRETCHER", "W^WHEELCH AIR" D
  8529   "RTN","VPR CORD4",229 ,0)
  8530    .S CNT=CN T+1,RADDET ("transpor t",CNT,"ui d")=$$SETU ID^VPRUTIL S("transpo rt","",$P( VPRX,U)),R ADDET("tra nsport",CN T,"name")= $P(VPRX,U, 2),RADDET( "transport ",CNT,"int ernal")=$P (VPRX,U)
  8531   "RTN","VPR CORD4",230 ,0)
  8532    Q
  8533   "RTN","VPR CORD4",231 ,0)
  8534    ;
  8535   "RTN","VPR CORD4",232 ,0)
  8536   CAT(RADDET ) ;categor y values
  8537   "RTN","VPR CORD4",233 ,0)
  8538    N CNT,VPR X
  8539   "RTN","VPR CORD4",234 ,0)
  8540    S CNT=0
  8541   "RTN","VPR CORD4",235 ,0)
  8542    F VPRX="I ^INPATIENT ","O^OUTPA TIENT","E^ EMPLOYEE", "C^CONTRAC T","S^SHAR ING","R^RE SEARCH" D
  8543   "RTN","VPR CORD4",236 ,0)
  8544    .S CNT=CN T+1,RADDET ("category ",CNT,"uid ")=$$SETUI D^VPRUTILS ("transpor t","",$P(V PRX,U)),RA DDET("cate gory",CNT, "name")=$P (VPRX,U,2) ,RADDET("c ategory",C NT,"intern al")=$P(VP RX,U)
  8545   "RTN","VPR CORD4",237 ,0)
  8546    Q
  8547   "RTN","VPR CORD4",238 ,0)
  8548    ;
  8549   "RTN","VPR CORD4",239 ,0)
  8550   URGENCY(UR G) ; Get t he allowab le urgenci es and def ault
  8551   "RTN","VPR CORD4",240 ,0)
  8552    N CNT,I,V PRX
  8553   "RTN","VPR CORD4",241 ,0)
  8554    S VPRX="" ,I=0,CNT=0
  8555   "RTN","VPR CORD4",242 ,0)
  8556    F  S ORX= $O(^ORD(10 1.42,"S.RA ",VPRX)) Q :VPRX=""   D
  8557   "RTN","VPR CORD4",243 ,0)
  8558    . S I=$O( ^ORD(101.4 2,"S.RA",V PRX,0))
  8559   "RTN","VPR CORD4",244 ,0)
  8560    . S URG(" urgency",C NT,"uid")= $$SETUID^V PRUTILS("u rgency","" ,I),URG("u rgency",CN T,"interna l")=I
  8561   "RTN","VPR CORD4",245 ,0)
  8562    . S URG(" urgency",C NT,"name") =VPRX
  8563   "RTN","VPR CORD4",246 ,0)
  8564    . S URG(" urgency",C NT,"defaul t")="false "
  8565   "RTN","VPR CORD4",247 ,0)
  8566    . S CNT=C NT+1
  8567   "RTN","VPR CORD4",248 ,0)
  8568    S I=$O(^O RD(101.42, "B","ROUTI NE",0)) I  +I=0 Q
  8569   "RTN","VPR CORD4",249 ,0)
  8570    S CNT=CNT +1
  8571   "RTN","VPR CORD4",250 ,0)
  8572    S URG("ur gency",CNT ,"uid")=$$ SETUID^VPR UTILS("urg ency","",I ),URG("urg ency",CNT, "internal" )=I
  8573   "RTN","VPR CORD4",251 ,0)
  8574    S URG("ur gency",CNT ,"name")=" Routine"
  8575   "RTN","VPR CORD4",252 ,0)
  8576    S URG("ur gency",CNT ,"default" )="true"
  8577   "RTN","VPR CORD4",253 ,0)
  8578    Q
  8579   "RTN","VPR CORD4",254 ,0)
  8580    ;
  8581   "RTN","VPR CORD4",255 ,0)
  8582   SUBMIT(SUB MIT,IMGTYP ) ; Get th e location s to which  the reque st may be  submitted
  8583   "RTN","VPR CORD4",256 ,0)
  8584    N CNT,FIR ST,TMPLST, ASK,VPRX
  8585   "RTN","VPR CORD4",257 ,0)
  8586    S CNT=0
  8587   "RTN","VPR CORD4",258 ,0)
  8588    D EN4^RAO 7PC1(IMGTY P,"TMPLST" )
  8589   "RTN","VPR CORD4",259 ,0)
  8590    S FIRST=1
  8591   "RTN","VPR CORD4",260 ,0)
  8592    S I=0 F   S I=$O(TMP LST(I)) Q: 'I  D
  8593   "RTN","VPR CORD4",261 ,0)
  8594    . S CNT=C NT+1,VPRX= $P(TMPLST( I),U,1,2), SUBMIT("su bmit",CNT, "name")=$P (VPRX,U,2)
  8595   "RTN","VPR CORD4",262 ,0)
  8596    . S SUBMI T("submit" ,CNT,"defa ult")=$S(F IRST=1:"tr ue",1:"fal se")
  8597   "RTN","VPR CORD4",263 ,0)
  8598    . S SUBMI T("submit" ,CNT,"uid" )=$$SETUID ^VPRUTILS( "imagingLo cation","" ,$P(VPRX,U )),SUBMIT( "submit",C NT,"intern al")=$P(VP RX,U),FIRS T=0
  8599   "RTN","VPR CORD4",264 ,0)
  8600    S VPRX=$$ GET^XPAR(" ALL","RA S UBMIT PROM PT",1,"Q")
  8601   "RTN","VPR CORD4",265 ,0)
  8602    S ASK=$S( $L(VPRX):V PRX,1:1)
  8603   "RTN","VPR CORD4",266 ,0)
  8604    S SUBMIT( "askSubmit ")=$S(ASK= 1:"true",A SK=0:"fals e",1:"true ")
  8605   "RTN","VPR CORD4",267 ,0)
  8606    Q
  8607   "RTN","VPR CORD4",268 ,0)
  8608    ;
  8609   "RTN","VPR CORD4",269 ,0)
  8610   QO ;
  8611   "RTN","VPR CORD4",270 ,0)
  8612    N IEN,NAM E,NODE,RES ULT
  8613   "RTN","VPR CORD4",271 ,0)
  8614    N ERRMSG  S ERRMSG=" A mumps er ror occurr ed while e xtaracting  orderable  items."
  8615   "RTN","VPR CORD4",272 ,0)
  8616    S IEN=0 F   S IEN=$O (^ORD(101. 41,IEN)) Q :IEN'>0  D
  8617   "RTN","VPR CORD4",273 ,0)
  8618    .N $ES,$E T
  8619   "RTN","VPR CORD4",274 ,0)
  8620    .S $ET="D  ERRHDLR^V PRDERRH"
  8621   "RTN","VPR CORD4",275 ,0)
  8622    .S NODE=$ G(^ORD(101 .41,IEN,0) ) I $P(NOD E,U,4)'="Q " Q
  8623   "RTN","VPR CORD4",276 ,0)
  8624    .S NAME=$ S($P(NODE, U,2)'="":$ P(NODE,U,2 ),1:$P(NOD E,U))
  8625   "RTN","VPR CORD4",277 ,0)
  8626    .S RESULT ("name")=N AME
  8627   "RTN","VPR CORD4",278 ,0)
  8628    .S RESULT ("uid")=$$ SETUID^VPR UTILS("qo" ,"",IEN),R ESULT("int ernal")=IE N
  8629   "RTN","VPR CORD4",279 ,0)
  8630    .S VPRCNT =VPRCNT+1  D ADD^VPRE F("RESULT" )
  8631   "RTN","VPR CORD4",280 ,0)
  8632    I IEN'>0  S VPRFINI= 1
  8633   "RTN","VPR CORD4",281 ,0)
  8634    Q
  8635   "RTN","VPR CORD4",282 ,0)
  8636    ;
  8637   "RTN","VPR CORD4",283 ,0)
  8638   VALIDOI(OI TYPE,IEN)  ;
  8639   "RTN","VPR CORD4",284 ,0)
  8640    N TEMP,TY PE
  8641   "RTN","VPR CORD4",285 ,0)
  8642    I $G(^ORD (101.43,IE N,0))'=""
  8643   "RTN","VPR CORD4",286 ,0)
  8644    S TEMP=$P (^ORD(101. 43,IEN,0), U,2)
  8645   "RTN","VPR CORD4",287 ,0)
  8646    S TYPE=$P (TEMP,";", 2)
  8647   "RTN","VPR CORD4",288 ,0)
  8648    S TYPE=$E (TYPE,3,$L (TYPE))
  8649   "RTN","VPR CORD4",289 ,0)
  8650    I OITYPE= "" Q TYPE
  8651   "RTN","VPR CORD4",290 ,0)
  8652    I TYPE["P S" Q TYPE
  8653   "RTN","VPR CORD4",291 ,0)
  8654    I OITYPE[ TYPE Q TYP E
  8655   "RTN","VPR CORD4",292 ,0)
  8656    Q ""
  8657   "RTN","VPR CORD4",293 ,0)
  8658    ;
  8659   "RTN","VPR CPAT")
  8660   0^9^B18789 518
  8661   "RTN","VPR CPAT",1,0)
  8662   VPRCPAT ;S LC/AGP - P atient Inf ormation C ontroller  for VPR ;  12/12/13 8 :52pm
  8663   "RTN","VPR CPAT",2,0)
  8664    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  8665   "RTN","VPR CPAT",3,0)
  8666    ;
  8667   "RTN","VPR CPAT",4,0)
  8668   ADD(X) ; A dd a line  @NHIN@(n)= X
  8669   "RTN","VPR CPAT",5,0)
  8670    S VPRCNT= $G(VPRCNT) +1
  8671   "RTN","VPR CPAT",6,0)
  8672    S @VPRXML @(VPRCNT)= X
  8673   "RTN","VPR CPAT",7,0)
  8674    Q
  8675   "RTN","VPR CPAT",8,0)
  8676    ;
  8677   "RTN","VPR CPAT",9,0)
  8678   RPC(VPRXML ,PARAMS) ;  Process r equest via  RPC inste ad of CSP
  8679   "RTN","VPR CPAT",10,0 )
  8680    N X,REQ,V PRCNT,VPRS ITE,VPRUSE R,VPRDBUG, VPRSTA
  8681   "RTN","VPR CPAT",11,0 )
  8682    S VPRXML= $NA(^TMP($ J,"VPR RES ULTS")) K  @VPRXML
  8683   "RTN","VPR CPAT",12,0 )
  8684    S VPRCNT= 0
  8685   "RTN","VPR CPAT",13,0 )
  8686    S VPRUSER =DUZ,VPRSI TE=DUZ(2), VPRSTA=$$S TA^XUAF4(D UZ(2))
  8687   "RTN","VPR CPAT",14,0 )
  8688    S X="" F   S X=$O(PA RAMS(X)) Q :X=""  S R EQ(X,1)=PA RAMS(X)
  8689   "RTN","VPR CPAT",15,0 )
  8690    ;
  8691   "RTN","VPR CPAT",16,0 )
  8692   COMMON ; C ome here f or both CS P and RPC  Mode
  8693   "RTN","VPR CPAT",17,0 )
  8694    ;
  8695   "RTN","VPR CPAT",18,0 )
  8696    N CMD
  8697   "RTN","VPR CPAT",19,0 )
  8698    S CMD=$G( REQ("comma nd",1))
  8699   "RTN","VPR CPAT",20,0 )
  8700    D ADD("<r esults>")
  8701   "RTN","VPR CPAT",21,0 )
  8702    ;
  8703   "RTN","VPR CPAT",22,0 )
  8704    I CMD="ge tPatPcmmIn fo" D  G O UT
  8705   "RTN","VPR CPAT",23,0 )
  8706    . D GETPC MM^VPRCPAT 1($$VAL("p atient"))
  8707   "RTN","VPR CPAT",24,0 )
  8708    ;
  8709   "RTN","VPR CPAT",25,0 )
  8710   OUT ; outp ut the XML
  8711   "RTN","VPR CPAT",26,0 )
  8712    D ADD("</ results>")
  8713   "RTN","VPR CPAT",27,0 )
  8714    ;I EDPDBU G D PUTXML ^EDPCDBG(E DPDBUG,.ED PXML)
  8715   "RTN","VPR CPAT",28,0 )
  8716    ;I $L($G( EDPHTTP))  D        ;  if in CSP  mode
  8717   "RTN","VPR CPAT",29,0 )
  8718    ;. U EDPH TTP
  8719   "RTN","VPR CPAT",30,0 )
  8720    ;. W "<re sults>",!
  8721   "RTN","VPR CPAT",31,0 )
  8722    ;. N I S  I=0 F  S I =$O(EDPXML (I)) Q:'I   W EDPXML( I),!
  8723   "RTN","VPR CPAT",32,0 )
  8724    ;. W "</r esults>",!
  8725   "RTN","VPR CPAT",33,0 )
  8726   END Q
  8727   "RTN","VPR CPAT",34,0 )
  8728    ;
  8729   "RTN","VPR CPAT",35,0 )
  8730   VAL(X) ; r eturn valu e from req uest
  8731   "RTN","VPR CPAT",36,0 )
  8732    Q $G(REQ( X,1))
  8733   "RTN","VPR CPAT",37,0 )
  8734    ;
  8735   "RTN","VPR CPAT",38,0 )
  8736    ;
  8737   "RTN","VPR CPAT",39,0 )
  8738    ; --- for  VPRCNTRL:  Expects V PRCMD(), D FN, UID, A RRAY
  8739   "RTN","VPR CPAT",40,0 )
  8740    ;
  8741   "RTN","VPR CPAT",41,0 )
  8742   EN ; -- Pa tient data  controlle r
  8743   "RTN","VPR CPAT",42,0 )
  8744    N CMD K V PRERR
  8745   "RTN","VPR CPAT",43,0 )
  8746    S CMD=$G( VPRCMD("co mmand"))
  8747   "RTN","VPR CPAT",44,0 )
  8748    ;
  8749   "RTN","VPR CPAT",45,0 )
  8750    I CMD="sa vePhone" D  PHONE G E NQ
  8751   "RTN","VPR CPAT",46,0 )
  8752    ; others  ??
  8753   "RTN","VPR CPAT",47,0 )
  8754    ;
  8755   "RTN","VPR CPAT",48,0 )
  8756   ENQ ; done
  8757   "RTN","VPR CPAT",49,0 )
  8758    I $D(VPRE RR) D ERRO R Q
  8759   "RTN","VPR CPAT",50,0 )
  8760    D POST^VP REVNT(DFN, "patient", DFN)
  8761   "RTN","VPR CPAT",51,0 )
  8762    D DPT1^VP RDJ00
  8763   "RTN","VPR CPAT",52,0 )
  8764    Q
  8765   "RTN","VPR CPAT",53,0 )
  8766    ;
  8767   "RTN","VPR CPAT",54,0 )
  8768   ERROR ; --  add error  info inst ead of upd ated data  object
  8769   "RTN","VPR CPAT",55,0 )
  8770    N ERROR
  8771   "RTN","VPR CPAT",56,0 )
  8772    S ERROR=" {""command "":"""_CMD _""",""suc cess"":fal se,""error "":"""_VPR ERR_"""}"
  8773   "RTN","VPR CPAT",57,0 )
  8774    S VPRI=VP RI+1 S:VPR I>1 @VPR@( VPRI,.3)=" ,"
  8775   "RTN","VPR CPAT",58,0 )
  8776    S @VPR@(V PRI,1)=ERR OR
  8777   "RTN","VPR CPAT",59,0 )
  8778    Q
  8779   "RTN","VPR CPAT",60,0 )
  8780    ;
  8781   "RTN","VPR CPAT",61,0 )
  8782   PHONE ; --  update ph one number s
  8783   "RTN","VPR CPAT",62,0 )
  8784    N VPRX,VP RDR,HOME,C ELL,NOK,EC ON,I,J,X,O K
  8785   "RTN","VPR CPAT",63,0 )
  8786    S (VPRDR, HOME,CELL, NOK,ECON)= "" D VALS( "old")
  8787   "RTN","VPR CPAT",64,0 )
  8788    S I="" F   S I=$O(AR RAY("telec oms",I)) Q :I<1  D
  8789   "RTN","VPR CPAT",65,0 )
  8790    . I $G(AR RAY("telec oms",I,"us ageCode")) ="H" D  Q
  8791   "RTN","VPR CPAT",66,0 )
  8792    .. S HOME =$G(ARRAY( "telecoms" ,I,"teleco m"))
  8793   "RTN","VPR CPAT",67,0 )
  8794    .. I HOME =HOME("old ") S HOME= "" Q            ;no c hange
  8795   "RTN","VPR CPAT",68,0 )
  8796    .. I "@"[ HOME S:$L( HOME("old" )) HOME="@ " Q  ;dele te
  8797   "RTN","VPR CPAT",69,0 )
  8798    .. S HOME =$$FORMAT( HOME),ARRA Y("telecom s",I,"tele com")=HOME
  8799   "RTN","VPR CPAT",70,0 )
  8800    . I $G(AR RAY("telec oms",I,"us ageCode")) ="MC" D  Q
  8801   "RTN","VPR CPAT",71,0 )
  8802    .. S CELL =$G(ARRAY( "telecoms" ,I,"teleco m"))
  8803   "RTN","VPR CPAT",72,0 )
  8804    .. I CELL =CELL("old ") S CELL= "" Q            ;no c hange
  8805   "RTN","VPR CPAT",73,0 )
  8806    .. I "@"[ CELL S:$L( CELL("old" )) CELL="@ " Q  ;dele te
  8807   "RTN","VPR CPAT",74,0 )
  8808    .. S CELL =$$FORMAT( CELL),ARRA Y("telecom s",I,"tele com")=CELL
  8809   "RTN","VPR CPAT",75,0 )
  8810    S I="" F   S I=$O(AR RAY("suppo rts",I)) Q :I<1  D
  8811   "RTN","VPR CPAT",76,0 )
  8812    . S X=$P( $G(ARRAY(" supports", I,"contact TypeCode") ),":",4) ; NOK or ECO N
  8813   "RTN","VPR CPAT",77,0 )
  8814    . S J=""  F  S J=$O( ARRAY("sup ports",I," telecomLis t",J)) Q:J <1  D
  8815   "RTN","VPR CPAT",78,0 )
  8816    .. Q:$G(A RRAY("supp orts",I,"t elecomList ",J,"usage Code"))'=" H"
  8817   "RTN","VPR CPAT",79,0 )
  8818    .. S @X=$ G(ARRAY("s upports",I ,"telecomL ist",J,"te lecom"))
  8819   "RTN","VPR CPAT",80,0 )
  8820    .. I @X=@ X@("old")  S @X="" Q                  ;no c hange
  8821   "RTN","VPR CPAT",81,0 )
  8822    .. I "@"[ @X S:$L(@X @("old"))  @X="@" Q        ;dele te
  8823   "RTN","VPR CPAT",82,0 )
  8824    .. S @X=$ $FORMAT(@X ),ARRAY("s upports",I ,"telecomL ist",J,"te lecom")=@X
  8825   "RTN","VPR CPAT",83,0 )
  8826    ;
  8827   "RTN","VPR CPAT",84,0 )
  8828    S:$L(HOME ) VPRX(.13 1)=HOME,VP RDR=".131"  ;@=delete
  8829   "RTN","VPR CPAT",85,0 )
  8830    S:$L(CELL ) VPRX(.13 4)=CELL,VP RDR=VPRDR_ $S($L(VPRD R):";",1:" ")_".134"
  8831   "RTN","VPR CPAT",86,0 )
  8832    S:$L(ECON ) VPRX(.33 9)=ECON,VP RDR=VPRDR_ $S($L(VPRD R):";",1:" ")_".339"
  8833   "RTN","VPR CPAT",87,0 )
  8834    S:$L(NOK)  VPRX(.219 )=NOK,VPRD R=VPRDR_$S ($L(VPRDR) :";",1:"") _".219"
  8835   "RTN","VPR CPAT",88,0 )
  8836    I '$O(VPR X(0)) S VP RERR="Data  not chang ed" Q  ;$$ ERR(5) Q
  8837   "RTN","VPR CPAT",89,0 )
  8838    D EDIT^VA FCPTED(DFN ,"VPRX",VP RDR)
  8839   "RTN","VPR CPAT",90,0 )
  8840    S X=$G(^D PT(DFN,.13 )),OK=1 D   ;check gl obal
  8841   "RTN","VPR CPAT",91,0 )
  8842    . I $L(HO ME),$S(HOM E="@":$L($ P(X,U)),1: (HOME'=$P( X,U))) S O K=0
  8843   "RTN","VPR CPAT",92,0 )
  8844    . I $L(CE LL),$S(CEL L="@":$L($ P(X,U,4)), 1:(CELL'=$ P(X,U,4)))  S OK=0
  8845   "RTN","VPR CPAT",93,0 )
  8846    . I $L(EC ON) S X=$G (^DPT(DFN, .33)) I $S (ECON="@": $L($P(X,U, 9)),1:(VPR X(.339)'=$ P(X,U,9)))  S OK=0
  8847   "RTN","VPR CPAT",94,0 )
  8848    . I $L(NO K) S X=$G( ^DPT(DFN,. 21)) I $S( NOK="@":$L ($P(X,U,9) ),1:(NOK'= $P(X,U,9)) ) S OK=0
  8849   "RTN","VPR CPAT",95,0 )
  8850    S:'OK VPR ERR="Updat e failed"  ;$$ERR(6)
  8851   "RTN","VPR CPAT",96,0 )
  8852    Q
  8853   "RTN","VPR CPAT",97,0 )
  8854    ;
  8855   "RTN","VPR CPAT",98,0 )
  8856   FORMAT(X)  ; -- enfor ce (xxx)xx x-xxxx pho ne format
  8857   "RTN","VPR CPAT",99,0 )
  8858    S X=$G(X)  I X?1"("3 N1")"3N1"- "4N.E Q X
  8859   "RTN","VPR CPAT",100, 0)
  8860    N P,N,I,Y  S P=""
  8861   "RTN","VPR CPAT",101, 0)
  8862    F I=1:1:$ L(X) S N=$ E(X,I) I N =+N S P=P_ N
  8863   "RTN","VPR CPAT",102, 0)
  8864    S:$L(P)<1 0 P=$E("00 00000000", 1,10-$L(P) )_P
  8865   "RTN","VPR CPAT",103, 0)
  8866    S Y=$S(P: "("_$E(P,1 ,3)_")"_$E (P,4,6)_"- "_$E(P,7,1 0),1:"")
  8867   "RTN","VPR CPAT",104, 0)
  8868    Q Y
  8869   "RTN","VPR CPAT",105, 0)
  8870    ;
  8871   "RTN","VPR CPAT",106, 0)
  8872   VALS(SUB)  ; -- pull  values fro m ^DPT
  8873   "RTN","VPR CPAT",107, 0)
  8874    N X S X=$ G(^DPT(DFN ,.13))
  8875   "RTN","VPR CPAT",108, 0)
  8876    S HOME(SU B)=$P(X,U) ,CELL(SUB) =$P(X,U,4)
  8877   "RTN","VPR CPAT",109, 0)
  8878    S X=$G(^D PT(DFN,.33 )),ECON(SU B)=$P(X,U, 9)
  8879   "RTN","VPR CPAT",110, 0)
  8880    S X=$G(^D PT(DFN,.21 )),NOK(SUB )=$P(X,U,9 )
  8881   "RTN","VPR CPAT",111, 0)
  8882    Q
  8883   "RTN","VPR CPAT1")
  8884   0^10^B7071 755
  8885   "RTN","VPR CPAT1",1,0 )
  8886   VPRCPAT1 ;  SLC/AGP,J LC - Proce ss Patient  Request f rom AVIVA  System. ;  05/27/2011
  8887   "RTN","VPR CPAT1",2,0 )
  8888    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  8889   "RTN","VPR CPAT1",3,0 )
  8890    Q
  8891   "RTN","VPR CPAT1",4,0 )
  8892    ;
  8893   "RTN","VPR CPAT1",5,0 )
  8894   ADD(X) ; A dd a line  @NHIN@(n)= X
  8895   "RTN","VPR CPAT1",6,0 )
  8896    S VPRCNT= $G(VPRCNT) +1
  8897   "RTN","VPR CPAT1",7,0 )
  8898    S @VPRXML @(VPRCNT)= X
  8899   "RTN","VPR CPAT1",8,0 )
  8900    Q
  8901   "RTN","VPR CPAT1",9,0 )
  8902    ;
  8903   "RTN","VPR CPAT1",10, 0)
  8904   AE(TEXT) ;
  8905   "RTN","VPR CPAT1",11, 0)
  8906    S VPRERCN T=VPRERCNT +1
  8907   "RTN","VPR CPAT1",12, 0)
  8908    S VPRERAR R(VPRERCNT )=TEXT
  8909   "RTN","VPR CPAT1",13, 0)
  8910    Q
  8911   "RTN","VPR CPAT1",14, 0)
  8912    ;
  8913   "RTN","VPR CPAT1",15, 0)
  8914   AEM(TEXT)  ;
  8915   "RTN","VPR CPAT1",16, 0)
  8916    N NUM
  8917   "RTN","VPR CPAT1",17, 0)
  8918    S NUM=0 F   S NUM=$O (TEXT(NUM) ) Q:NUM'>0   D
  8919   "RTN","VPR CPAT1",18, 0)
  8920    .S VPRERC NT=VPRERCN T+1
  8921   "RTN","VPR CPAT1",19, 0)
  8922    .S VPRERA RR(VPRERCN T)=TEXT(NU M)
  8923   "RTN","VPR CPAT1",20, 0)
  8924    Q
  8925   "RTN","VPR CPAT1",21, 0)
  8926    ;
  8927   "RTN","VPR CPAT1",22, 0)
  8928   GETPCMM(IC N) ;
  8929   "RTN","VPR CPAT1",23, 0)
  8930    N DFN,VPR DATA,VPRDC NT,VPRERAR R,VPRERCNT
  8931   "RTN","VPR CPAT1",24, 0)
  8932    S VPRERCN T=0,VPRDCN T=0
  8933   "RTN","VPR CPAT1",25, 0)
  8934    S DFN=$$G ETDFN^MPIF 001(ICN) I  DFN'>0 D  AE("Cannot  find pati ent dfn fr om ICN") G  EXIT
  8935   "RTN","VPR CPAT1",26, 0)
  8936    N PCT,PCP ,ATT,ASS
  8937   "RTN","VPR CPAT1",27, 0)
  8938    S PCT=$$O UTPTTM^SDU TL3(DFN,DT ) I $P(PCT ,U)>0 S VP RDCNT=VPRD CNT+1,VPRD ATA(VPRDCN T)="<team  id='"_$P(P CT,U)_"' v alue='"_$$ ESC^VPRD($ P(PCT,U,2) )_"'/>"
  8939   "RTN","VPR CPAT1",28, 0)
  8940    S PCP=$$O UTPTPR^SDU TL3(DFN,DT ) I $P(PCP ,U)>0 S VP RDCNT=VPRD CNT+1,VPRD ATA(VPRDCN T)="<prima ryProvider  id='"_$P( PCP,U)_"'  value='"_$ $ESC^VPRD( $P(PCP,U,2 ))_"'/>"
  8941   "RTN","VPR CPAT1",29, 0)
  8942    S ATT=$G( ^DPT(DFN,. 1041)) I A TT S VPRDC NT=VPRDCNT +1,VPRDATA (VPRDCNT)= "<attendin gProvider  id='"_ATT_ "' value=' "_$$ESC^VP RD($P($G(^ VA(200,ATT ,0)),U))_" '/>"
  8943   "RTN","VPR CPAT1",30, 0)
  8944    S ASS=$$O UTPTAP^SDU TL3(DFN,DT ) I $P(ASS ,U)>0 S VP RDCNT=VPRD CNT+1,VPRD ATA(VPRDCN T)="<assoc iateProvid er id='"_$ P(ASS,U)_" ' value='" _$$ESC^VPR D($P(ASS,U ,2))_"'/>"
  8945   "RTN","VPR CPAT1",31, 0)
  8946    G EXIT
  8947   "RTN","VPR CPAT1",32, 0)
  8948    Q
  8949   "RTN","VPR CPAT1",33, 0)
  8950    ;
  8951   "RTN","VPR CPAT1",34, 0)
  8952   EXIT ;
  8953   "RTN","VPR CPAT1",35, 0)
  8954    N CNT
  8955   "RTN","VPR CPAT1",36, 0)
  8956    I $D(VPRE RARR) D  Q
  8957   "RTN","VPR CPAT1",37, 0)
  8958    .D ADD("< success>fa lse</succe ss>")
  8959   "RTN","VPR CPAT1",38, 0)
  8960    .D ADD("< error>")
  8961   "RTN","VPR CPAT1",39, 0)
  8962    .D ADD("< message xm l:space='p reserve'/> ")
  8963   "RTN","VPR CPAT1",40, 0)
  8964    .S CNT=0  F  S CNT=$ O(VPRERARR (CNT)) Q:C NT'>0  D
  8965   "RTN","VPR CPAT1",41, 0)
  8966    ..D ADD($ $ESC^VPRD( VPRERARR(C NT)))
  8967   "RTN","VPR CPAT1",42, 0)
  8968    .D ADD("< /error>")
  8969   "RTN","VPR CPAT1",43, 0)
  8970    D ADD("<s uccess>tru e</success >")
  8971   "RTN","VPR CPAT1",44, 0)
  8972    D ADD("<d ata>")
  8973   "RTN","VPR CPAT1",45, 0)
  8974    S CNT=0 F   S CNT=$O (VPRDATA(C NT)) Q:CNT '>0  D
  8975   "RTN","VPR CPAT1",46, 0)
  8976    .D ADD(VP RDATA(CNT) )
  8977   "RTN","VPR CPAT1",47, 0)
  8978    D ADD("</ data>")
  8979   "RTN","VPR CPAT1",48, 0)
  8980    Q
  8981   "RTN","VPR CPRS")
  8982   0^47^B4945 756
  8983   "RTN","VPR CPRS",1,0)
  8984   VPRCPRS ;S LC/AGP - C PRS RPC fo r  ; 9/21/ 12 5:57pm
  8985   "RTN","VPR CPRS",2,0)
  8986    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  8987   "RTN","VPR CPRS",3,0)
  8988    ;
  8989   "RTN","VPR CPRS",4,0)
  8990    ;
  8991   "RTN","VPR CPRS",5,0)
  8992   RPC(VPROUT ,PARAMS) ;  Process r equest via  RPC inste ad of CSP
  8993   "RTN","VPR CPRS",6,0)
  8994    N X,REQ,V PRCNT,VPRS ITE,VPRUSE R,VPRDBUG, VPRSTA
  8995   "RTN","VPR CPRS",7,0)
  8996    S VPRCNT= 0
  8997   "RTN","VPR CPRS",8,0)
  8998    S VPRUSER =DUZ,VPRSI TE=DUZ(2), VPRSTA=$$S TA^XUAF4(D UZ(2))
  8999   "RTN","VPR CPRS",9,0)
  9000    S X="" F   S X=$O(PA RAMS(X)) Q :X=""  S R EQ(X,1)=PA RAMS(X)
  9001   "RTN","VPR CPRS",10,0 )
  9002    ;
  9003   "RTN","VPR CPRS",11,0 )
  9004   COMMON ; C ome here f or both CS P and RPC  Mode
  9005   "RTN","VPR CPRS",12,0 )
  9006    ;
  9007   "RTN","VPR CPRS",13,0 )
  9008    N CMD
  9009   "RTN","VPR CPRS",14,0 )
  9010    S CMD=$G( REQ("comma nd",1))
  9011   "RTN","VPR CPRS",15,0 )
  9012    ;
  9013   "RTN","VPR CPRS",16,0 )
  9014    ; returns  an order  structure  for change  orders
  9015   "RTN","VPR CPRS",17,0 )
  9016    ; or plac es an orde r if auto- accept QO
  9017   "RTN","VPR CPRS",18,0 )
  9018    I CMD="al erts" D  G  OUT
  9019   "RTN","VPR CPRS",19,0 )
  9020    . D ALERT S(.VPROUT)
  9021   "RTN","VPR CPRS",20,0 )
  9022    ;
  9023   "RTN","VPR CPRS",21,0 )
  9024    I CMD="re minders" D   G OUT
  9025   "RTN","VPR CPRS",22,0 )
  9026    .D EVALLI ST^VPRPXRM (.VPROUT,$ $VAL("pati entId"),$$ VAL("userI d"),$$VAL( "location" ))
  9027   "RTN","VPR CPRS",23,0 )
  9028    ;
  9029   "RTN","VPR CPRS",24,0 )
  9030   OUT ;
  9031   "RTN","VPR CPRS",25,0 )
  9032   END ;
  9033   "RTN","VPR CPRS",26,0 )
  9034    ;
  9035   "RTN","VPR CPRS",27,0 )
  9036   BLDINFO(IN FO) ;
  9037   "RTN","VPR CPRS",28,0 )
  9038    N X
  9039   "RTN","VPR CPRS",29,0 )
  9040    S X="" F   S X=$O(RE Q(X)) Q:X= ""  D
  9041   "RTN","VPR CPRS",30,0 )
  9042    .S INFO(X )=REQ(X,1)
  9043   "RTN","VPR CPRS",31,0 )
  9044    Q
  9045   "RTN","VPR CPRS",32,0 )
  9046    ;
  9047   "RTN","VPR CPRS",33,0 )
  9048   VAL(X) ; r eturn valu e from req uest
  9049   "RTN","VPR CPRS",34,0 )
  9050    Q $G(REQ( X,1))
  9051   "RTN","VPR CPRS",35,0 )
  9052    ;
  9053   "RTN","VPR CPRS",36,0 )
  9054   ALERTS(VPR OUT) ;
  9055   "RTN","VPR CPRS",37,0 )
  9056    N ALERT,C NT,ERROR,N ODE,NUM,RE SULT,VPROR Y
  9057   "RTN","VPR CPRS",38,0 )
  9058    K ^TMP("V PRALERTS", $J),^TMP(" VPROUT",$J )
  9059   "RTN","VPR CPRS",39,0 )
  9060    ;S VPROUT =$NA(^TMP( "VPROUT",$ J))
  9061   "RTN","VPR CPRS",40,0 )
  9062    D FASTUSE R^ORWORB(. VPRORY)
  9063   "RTN","VPR CPRS",41,0 )
  9064    ;ZW VPROR Y
  9065   "RTN","VPR CPRS",42,0 )
  9066    S CNT=0,N UM=1 F  S  CNT=$O(@VP RORY@(CNT) ) Q:CNT'>0   D
  9067   "RTN","VPR CPRS",43,0 )
  9068    .S NODE=$ G(@VPRORY@ (CNT))
  9069   "RTN","VPR CPRS",44,0 )
  9070    .K ALERT
  9071   "RTN","VPR CPRS",45,0 )
  9072    .I $P(NOD E,U)="I" S  ALERT("in foOnly")=" I"
  9073   "RTN","VPR CPRS",46,0 )
  9074    .S ALERT( "patient") =$P(NODE,U ,2),ALERT( "urgency") =$P(NODE,U ,4),ALERT( "dateTime" )=$P(NODE, U,5)
  9075   "RTN","VPR CPRS",47,0 )
  9076    .I $P(NOD E,U,3)'=""  S ALERT(" location") =$P(NODE,U ,3)
  9077   "RTN","VPR CPRS",48,0 )
  9078    .S ALERT( "message") =$P(NODE,U ,6)
  9079   "RTN","VPR CPRS",49,0 )
  9080    .I $P(NOD E,U,8)'=""  S ALERT(" action")=$ P(NODE,U,8 )
  9081   "RTN","VPR CPRS",50,0 )
  9082    .S ALERT( "mustBePro cess")=$S( $P(NODE,U, 9)="yes":" false",1:" true")
  9083   "RTN","VPR CPRS",51,0 )
  9084    .I $P(NOD E,U,10)'=" " S ALERT( "forwardBy ")="true"
  9085   "RTN","VPR CPRS",52,0 )
  9086    .M ^TMP(" VPRALERTS" ,$J,"data" ,"alerts", NUM,"alert ")=ALERT S  NUM=NUM+1
  9087   "RTN","VPR CPRS",53,0 )
  9088    D ENCODE^ VPRJSON($N A(^TMP("VP RALERTS",$ J)),"VPROU T","ERROR" )
  9089   "RTN","VPR CPRS",54,0 )
  9090    Q
  9091   "RTN","VPR CPRS",55,0 )
  9092    ;
  9093   "RTN","VPR CRPC")
  9094   0^19^B1303 7791
  9095   "RTN","VPR CRPC",1,0)
  9096   VPRCRPC ;S LC/AGP - G eneric RPC  controlle r for VPR  ; 11/7/12  5:42pm
  9097   "RTN","VPR CRPC",2,0)
  9098    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  9099   "RTN","VPR CRPC",3,0)
  9100    ;
  9101   "RTN","VPR CRPC",4,0)
  9102    ;
  9103   "RTN","VPR CRPC",5,0)
  9104   CHAINRPC(V PRRES,PARA MS) ; Chai n multiple  rpcs into  one call
  9105   "RTN","VPR CRPC",6,0)
  9106    N CITER,R SP,PID
  9107   "RTN","VPR CRPC",7,0)
  9108    S CITER=" " F  S CIT ER=$O(PARA MS("comman dList",CIT ER)) Q:CIT ER=""  D
  9109   "RTN","VPR CRPC",8,0)
  9110    . N SUBCM D,SUBRSP,X
  9111   "RTN","VPR CRPC",9,0)
  9112    . S X=""
  9113   "RTN","VPR CRPC",10,0 )
  9114    . F  S X= $O(PARAMS( "commandLi st",CITER, X)) Q:X=""   M SUBCMD (X)=PARAMS ("commandL ist",CITER ,X)
  9115   "RTN","VPR CRPC",11,0 )
  9116    . D CHAIN CMD(.SUBCM D,.SUBRSP)
  9117   "RTN","VPR CRPC",12,0 )
  9118    . I $D(SU BRSP) D DE CODE^VPRJS ON("SUBRSP ","RSP(SUB CMD(""comm and""))"," ^JMCERR")  I 1
  9119   "RTN","VPR CRPC",13,0 )
  9120    . I '$TES T S RSP(SU BCMD("comm and"))=""
  9121   "RTN","VPR CRPC",14,0 )
  9122    D ENCODE^ VPRJSON("R SP","VPRRE S","^JMCER R")
  9123   "RTN","VPR CRPC",15,0 )
  9124    Q
  9125   "RTN","VPR CRPC",16,0 )
  9126   RPC(VPRRES ,PARAMS) ;  Process r equest via  RPC inste ad of CSP
  9127   "RTN","VPR CRPC",17,0 )
  9128    N X,REQ,V PRVAL,VPRC NT,VPRSITE ,VPRUSER,V PRDBUG,VPR STA
  9129   "RTN","VPR CRPC",18,0 )
  9130    ;S VPRXML =$NA(^TMP( $J,"VPR RE SULTS")) K  @VPRXML
  9131   "RTN","VPR CRPC",19,0 )
  9132    S VPRCNT= 0
  9133   "RTN","VPR CRPC",20,0 )
  9134    ;S VPRUSE R=DUZ,VPRS ITE=DUZ(2) ,VPRSTA=$$ STA^XUAF4( DUZ(2))
  9135   "RTN","VPR CRPC",21,0 )
  9136    S X="" F   S X=$O(PA RAMS(X)) Q :X=""  I X '="value"  S REQ(X,1) =PARAMS(X)
  9137   "RTN","VPR CRPC",22,0 )
  9138    I $D(PARA MS("value" )) M VPRVA L=PARAMS(" value")
  9139   "RTN","VPR CRPC",23,0 )
  9140    ;
  9141   "RTN","VPR CRPC",24,0 )
  9142   COMMON ; C ome here f or both CS P and RPC  Mode
  9143   "RTN","VPR CRPC",25,0 )
  9144    ; 
  9145   "RTN","VPR CRPC",26,0 )
  9146    N CMD
  9147   "RTN","VPR CRPC",27,0 )
  9148    S CMD=$G( REQ("comma nd",1))
  9149   "RTN","VPR CRPC",28,0 )
  9150    ;
  9151   "RTN","VPR CRPC",29,0 )
  9152    I CMD="sa veParam" D   G OUT
  9153   "RTN","VPR CRPC",30,0 )
  9154    . D PUTPA RAM^VPRPAR AM(.VPRRES ,.VPRVAL," ")
  9155   "RTN","VPR CRPC",31,0 )
  9156    ;
  9157   "RTN","VPR CRPC",32,0 )
  9158    I CMD="sa veParamByU id" D  G O UT
  9159   "RTN","VPR CRPC",33,0 )
  9160    . D PUTBY UID^VPRPAR AM(.VPRRES ,$$VAL("ui d"),.VPRVA L)
  9161   "RTN","VPR CRPC",34,0 )
  9162    ;
  9163   "RTN","VPR CRPC",35,0 )
  9164    I CMD="ge tParam" D   G OUT
  9165   "RTN","VPR CRPC",36,0 )
  9166    . D GETBY UID^VPRPAR AM(.VPRRES ,$$VAL("ui d"))
  9167   "RTN","VPR CRPC",37,0 )
  9168    ;
  9169   "RTN","VPR CRPC",38,0 )
  9170    I CMD="cl earParam"  D  G OUT
  9171   "RTN","VPR CRPC",39,0 )
  9172    . D DELPA RAM^VPRPAR AM(.VPRRES ,$$VAL("ui d"))
  9173   "RTN","VPR CRPC",40,0 )
  9174    ;
  9175   "RTN","VPR CRPC",41,0 )
  9176    I CMD="ge tAllParam"  D  G OUT
  9177   "RTN","VPR CRPC",42,0 )
  9178    .D GETALP AR^VPRPARA M(.VPRRES, $$VAL("ent ity"),$$VA L("entityI d"),$$VAL( "getValues "))
  9179   "RTN","VPR CRPC",43,0 )
  9180    ;
  9181   "RTN","VPR CRPC",44,0 )
  9182    I CMD="ge tUserInfo"  D  G OUT
  9183   "RTN","VPR CRPC",45,0 )
  9184    .D GETUSE RI^VPRCRPC 1(.VPRRES, $$VAL("use rId"))
  9185   "RTN","VPR CRPC",46,0 )
  9186    ;
  9187   "RTN","VPR CRPC",47,0 )
  9188    I CMD="ge tPatientIn fo" D  G O UT
  9189   "RTN","VPR CRPC",48,0 )
  9190    .D GETPAT I^VPRCRPC1 (.VPRRES,$ $VAL("pati entId"))
  9191   "RTN","VPR CRPC",49,0 )
  9192    ;
  9193   "RTN","VPR CRPC",50,0 )
  9194    I CMD="ge tPatientCh ecks" D  G  OUT
  9195   "RTN","VPR CRPC",51,0 )
  9196    .D CHKS^V PRFPTC(.VP RRES,$$VAL ("patientI d"))
  9197   "RTN","VPR CRPC",52,0 )
  9198    ;
  9199   "RTN","VPR CRPC",53,0 )
  9200    I CMD="lo gPatientAc cess" D  G  OUT
  9201   "RTN","VPR CRPC",54,0 )
  9202    .D LOG^VP RFPTC(.VPR RES,$$VAL( "patientId "))
  9203   "RTN","VPR CRPC",55,0 )
  9204    ;
  9205   "RTN","VPR CRPC",56,0 )
  9206    I CMD="ad dTask" D   G OUT
  9207   "RTN","VPR CRPC",57,0 )
  9208    .D PUT^VP RDJ1(.VPRR ES,$$VAL(" patientId" ),$$VAL("t ype"),.VPR VAL)
  9209   "RTN","VPR CRPC",58,0 )
  9210    ;
  9211   "RTN","VPR CRPC",59,0 )
  9212    I CMD="ge tReminderL ist" D  G  OUT
  9213   "RTN","VPR CRPC",60,0 )
  9214    .D REMLIS T^VPRPXRM( .VPRRES,$$ VAL("user" ),$$VAL("l ocation"))
  9215   "RTN","VPR CRPC",61,0 )
  9216    ;
  9217   "RTN","VPR CRPC",62,0 )
  9218    I CMD="ev aluateRemi nder" D  G  OUT
  9219   "RTN","VPR CRPC",63,0 )
  9220    .D EVALRE M^VPRPXRM( .VPRRES,$$ VAL("patie ntId"),$$V AL("uid"))
  9221   "RTN","VPR CRPC",64,0 )
  9222    ;
  9223   "RTN","VPR CRPC",65,0 )
  9224    I CMD="ge tDefaultPa tientList"  D  G OUT
  9225   "RTN","VPR CRPC",66,0 )
  9226    .D GETDLI ST^VPRROS8 (.VPRRES,$ $VAL("serv er"))
  9227   "RTN","VPR CRPC",67,0 )
  9228    ;
  9229   "RTN","VPR CRPC",68,0 )
  9230    I CMD="ge tWardList"  D  G OUT
  9231   "RTN","VPR CRPC",69,0 )
  9232    .D GETWLI ST^VPRROS8 (.VPRRES,$ $VAL("serv er"),$$VAL ("id"))
  9233   "RTN","VPR CRPC",70,0 )
  9234    ;
  9235   "RTN","VPR CRPC",71,0 )
  9236    I CMD="ge tClinicLis t" D  G OU T
  9237   "RTN","VPR CRPC",72,0 )
  9238    .D GETCLI ST^VPRROS8 (.VPRRES,$ $VAL("serv er"),$$VAL ("id"),$$V AL("start" ),$$VAL("e nd"))
  9239   "RTN","VPR CRPC",73,0 )
  9240    ;
  9241   "RTN","VPR CRPC",74,0 )
  9242   OUT ; outp ut the XML
  9243   "RTN","VPR CRPC",75,0 )
  9244    ;S VPRRES =$G(RESULT )
  9245   "RTN","VPR CRPC",76,0 )
  9246    I '$D(VPR RES) S VPR RES="{}"
  9247   "RTN","VPR CRPC",77,0 )
  9248   END Q
  9249   "RTN","VPR CRPC",78,0 )
  9250    ;
  9251   "RTN","VPR CRPC",79,0 )
  9252   VAL(X) ; r eturn valu e from req uest
  9253   "RTN","VPR CRPC",80,0 )
  9254    Q $G(REQ( X,1))
  9255   "RTN","VPR CRPC",81,0 )
  9256    ;
  9257   "RTN","VPR CRPC",82,0 )
  9258   CHAINCMD(V PRCMD,VPRR SP) ; Do o ne command  in chain
  9259   "RTN","VPR CRPC",83,0 )
  9260    ; 
  9261   "RTN","VPR CRPC",84,0 )
  9262    N CMD
  9263   "RTN","VPR CRPC",85,0 )
  9264    S CMD=$G( VPRCMD("co mmand"))
  9265   "RTN","VPR CRPC",86,0 )
  9266    I CMD="ge tParam" D  GETBYUID^V PRPARAM(.V PRRSP,$G(V PRCMD("uid ")))
  9267   "RTN","VPR CRPC",87,0 )
  9268    I CMD="ge tPatientIn fo" D GETP ATI^VPRCRP C1(.VPRRSP ,$G(VPRCMD ("patientI d")))
  9269   "RTN","VPR CRPC",88,0 )
  9270    I CMD="ge tPatientCh ecks" D CH KS^VPRFPTC (.VPRRSP,$ G(VPRCMD(" patientId" )))
  9271   "RTN","VPR CRPC",89,0 )
  9272    I CMD="sa veParam" D  PUTPARAM^ VPRPARAM(. VPRRSP,$G( VPRCMD("va lue")),"")
  9273   "RTN","VPR CRPC",90,0 )
  9274    I CMD="sa veParamByU id" D PUTB YUID^VPRPA RAM(.VPRRS P,$G(VPRCM D("uid")), $G(VPRCMD( "value")))
  9275   "RTN","VPR CRPC",91,0 )
  9276    Q
  9277   "RTN","VPR CRPC1")
  9278   0^20^B1151 58851
  9279   "RTN","VPR CRPC1",1,0 )
  9280   VPRCRPC1 ;  SLC/AGP -  Patient a nd User ro utine. ; 0 5/01/14
  9281   "RTN","VPR CRPC1",2,0 )
  9282    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  9283   "RTN","VPR CRPC1",3,0 )
  9284    Q
  9285   "RTN","VPR CRPC1",4,0 )
  9286    ;
  9287   "RTN","VPR CRPC1",5,0 )
  9288   GETADD(VAL UES,DFN) ;
  9289   "RTN","VPR CRPC1",6,0 )
  9290    D ADD^VAD PT
  9291   "RTN","VPR CRPC1",7,0 )
  9292    N INC,NUM ,TEMP
  9293   "RTN","VPR CRPC1",8,0 )
  9294    I VAPA(12 )=1 D
  9295   "RTN","VPR CRPC1",9,0 )
  9296    .I $L(VAP A(13))>0 S  VALUES("c onfidentIa lAddress", "street",0 )=VAPA(13)
  9297   "RTN","VPR CRPC1",10, 0)
  9298    .I $L(VAP A(14))>0 S  VALUES("c onfidentIa lAddress", "street",1 )=VAPA(14)
  9299   "RTN","VPR CRPC1",11, 0)
  9300    .I $L(VAP A(15))>0 S  VALUES("c onfidentIa lAddress", "street",2 )=VAPA(15)
  9301   "RTN","VPR CRPC1",12, 0)
  9302    .I $L(VAP A(16))>0 S  VALUES("c onfidentIa lAddress", "city")=VA PA(16)
  9303   "RTN","VPR CRPC1",13, 0)
  9304    .I $L(VAP A(17))>0 S  VALUES("c onfidentIa lAddress", "state")=$ P(VAPA(17) ,U,2)
  9305   "RTN","VPR CRPC1",14, 0)
  9306    .I $L(VAP A(18))>0 S  VALUES("c onfidentIa lAddress", "zip")=VAP A(18)
  9307   "RTN","VPR CRPC1",15, 0)
  9308    .I $L(VAP A(20))>0 S  VALUES("c onfidentIa lAddress", "startDate ")=$P(VAPA (20),U,2)
  9309   "RTN","VPR CRPC1",16, 0)
  9310    .I $L(VAP A(21))>0 S  VALUES("c onfidentIa lAddress", "stopDate" )=$P(VAPA( 21),U,2)
  9311   "RTN","VPR CRPC1",17, 0)
  9312    .S INC=0, NUM=0 F  S  INC=$O(VA PA(22,INC) ) Q:INC=""   D
  9313   "RTN","VPR CRPC1",18, 0)
  9314    ..S NUM=N UM+1,VALUE S("confide ntIalAddre ss","catgo ries",NUM, "category" )=$P(VAPA( 22,INC),U, 2)
  9315   "RTN","VPR CRPC1",19, 0)
  9316    ..S VALUE S("confide ntIalAddre ss","catgo ries",NUM, "status")= $S($P(VAPA (22,INC),U ,3)="Y":"t rue",1:"fa lse")
  9317   "RTN","VPR CRPC1",20, 0)
  9318    ;
  9319   "RTN","VPR CRPC1",21, 0)
  9320    ;I $L(VAP A(1))>0 S  VALUES("ad dress","st reet",0)=V APA(1)
  9321   "RTN","VPR CRPC1",22, 0)
  9322    ;I $L(VAP A(2))>0 S  VALUES("ad dress","st reet",1)=V APA(2)
  9323   "RTN","VPR CRPC1",23, 0)
  9324    ;I $L(VAP A(3))>0 S  VALUES("ad dress","st reet",2)=V APA(3)
  9325   "RTN","VPR CRPC1",24, 0)
  9326    ;I $L(VAP A(4))>0 S  VALUES("ad dress","ci ty")=VAPA( 4)
  9327   "RTN","VPR CRPC1",25, 0)
  9328    ;I $L(VAP A(5))>0 S  VALUES("ad dress","st ate")=$P(V APA(5),U,2 )
  9329   "RTN","VPR CRPC1",26, 0)
  9330    ;I $L(VAP A(6))>0 S  VALUES("ad dress","zi p")=VAPA(6 )
  9331   "RTN","VPR CRPC1",27, 0)
  9332    I VAPA(9) ]"" S VALU ES("tempor aryAddress ","startDa te")=$P(VA PA(9),U,2)
  9333   "RTN","VPR CRPC1",28, 0)
  9334    I VAPA(10 )]"" S VAL UES("tempo raryAddres s","stopDa te")=$P(VA PA(10),U,2 )
  9335   "RTN","VPR CRPC1",29, 0)
  9336   ADDX ;
  9337   "RTN","VPR CRPC1",30, 0)
  9338    ;I $L(VAP A(8))>0 S  VALUES("ad dress","ph one")=VAPA (8)
  9339   "RTN","VPR CRPC1",31, 0)
  9340    I $P($G(^ DPT(DFN,.1 3)),U,3)'= "" S VALUE S("email") =$P($G(^DP T(DFN,.13) ),U,3)
  9341   "RTN","VPR CRPC1",32, 0)
  9342    I +$P($G( ^DPT(DFN,. 11)),U,16) >0 S VALUE S("badAddr ess")=$$GE T1^DIQ(2,D FN_",",.12 1)
  9343   "RTN","VPR CRPC1",33, 0)
  9344    D KVAR^VA DPT
  9345   "RTN","VPR CRPC1",34, 0)
  9346    Q
  9347   "RTN","VPR CRPC1",35, 0)
  9348    ;
  9349   "RTN","VPR CRPC1",36, 0)
  9350   GETBSA(DFN ) ;
  9351   "RTN","VPR CRPC1",37, 0)
  9352    N DATE,DA TA,NFOUND, TEST,TEXT
  9353   "RTN","VPR CRPC1",38, 0)
  9354    S TEST=""
  9355   "RTN","VPR CRPC1",39, 0)
  9356    D BSA^PXR MBMI(DFN,1 ,0,DT,.NFO UND,.TEST, .DATE,.DAT A,.TEXT)
  9357   "RTN","VPR CRPC1",40, 0)
  9358    Q +$G(DAT A(1,"BSA") )
  9359   "RTN","VPR CRPC1",41, 0)
  9360    ;
  9361   "RTN","VPR CRPC1",42, 0)
  9362   GETBMI(DFN ) ;
  9363   "RTN","VPR CRPC1",43, 0)
  9364    ;  BMI(DF N,NGET,BDT ,EDT,NFOUN D,TEST,DAT E,DATA,TEX T) 
  9365   "RTN","VPR CRPC1",44, 0)
  9366    N DATE,DA TA,NFOUND, TEST,TEXT
  9367   "RTN","VPR CRPC1",45, 0)
  9368    D BMI^PXR MBMI(DFN,1 ,0,DT,.NFO UND,.TEST, .DATE,.DAT A,.TEXT)
  9369   "RTN","VPR CRPC1",46, 0)
  9370    Q +$G(DAT A(1,"BMI") )
  9371   "RTN","VPR CRPC1",47, 0)
  9372    ;
  9373   "RTN","VPR CRPC1",48, 0)
  9374   GETDEM(VAL UES,DFN) ;
  9375   "RTN","VPR CRPC1",49, 0)
  9376    D DEM^VAD PT
  9377   "RTN","VPR CRPC1",50, 0)
  9378    S VALUES( "name")=VA DM(1)
  9379   "RTN","VPR CRPC1",51, 0)
  9380    I VADM(2) ]"" S VALU ES("ssn")= $P(VADM(2) ,U,2)
  9381   "RTN","VPR CRPC1",52, 0)
  9382    I VADM(3) ]"" S VALU ES("dob")= $P(VADM(3) ,U,2)
  9383   "RTN","VPR CRPC1",53, 0)
  9384    I VADM(4) ]"" S VALU ES("age")= VADM(4)
  9385   "RTN","VPR CRPC1",54, 0)
  9386    I VADM(5) ]"" S VALU ES("gender ")=$P(VADM (5),U,2)
  9387   "RTN","VPR CRPC1",55, 0)
  9388    I VADM(6) ]"" S VALU ES("dateDe ath")=$P(V ADM(6),U,2 )
  9389   "RTN","VPR CRPC1",56, 0)
  9390    I VADM(7) ]"" S VALU ES("remark s")=VADM(7 )
  9391   "RTN","VPR CRPC1",57, 0)
  9392    I VADM(8) ]"" S VALU ES("race") =$P(VADM(8 ),U,2)
  9393   "RTN","VPR CRPC1",58, 0)
  9394    D KVAR^VA DPT
  9395   "RTN","VPR CRPC1",59, 0)
  9396    Q
  9397   "RTN","VPR CRPC1",60, 0)
  9398    ;
  9399   "RTN","VPR CRPC1",61, 0)
  9400   GETKEYS(VA LUES,USER)  ;
  9401   "RTN","VPR CRPC1",62, 0)
  9402    N NAME,VP RERR,VPRLI ST,CNT
  9403   "RTN","VPR CRPC1",63, 0)
  9404    D LIST^DI C(200.051, ","_USER_" ,",".01",, ,,,,,,"VPR LIST","VPR ERR")
  9405   "RTN","VPR CRPC1",64, 0)
  9406    S CNT=0 F   S CNT=$O (VPRLIST(" DILIST",1, CNT)) Q:CN T'>0  D
  9407   "RTN","VPR CRPC1",65, 0)
  9408    . S NAME= $G(VPRLIST ("DILIST", 1,CNT)) Q: NAME=""
  9409   "RTN","VPR CRPC1",66, 0)
  9410    . S VALUE S("vistaKe ys",NAME)= "TRUE"
  9411   "RTN","VPR CRPC1",67, 0)
  9412    Q
  9413   "RTN","VPR CRPC1",68, 0)
  9414    ;
  9415   "RTN","VPR CRPC1",69, 0)
  9416   GETNOK(VAL UES,DFN,TY PE) ;
  9417   "RTN","VPR CRPC1",70, 0)
  9418    S VAOA("A ")=TYPE
  9419   "RTN","VPR CRPC1",71, 0)
  9420    N CNT,CON TACT
  9421   "RTN","VPR CRPC1",72, 0)
  9422    S CONTACT =$S(TYPE=3 :"secondar y",1:"prim ary")
  9423   "RTN","VPR CRPC1",73, 0)
  9424    S CNT=$S( TYPE=3:2,1 :1)
  9425   "RTN","VPR CRPC1",74, 0)
  9426    D OAD^VAD PT
  9427   "RTN","VPR CRPC1",75, 0)
  9428    ;
  9429   "RTN","VPR CRPC1",76, 0)
  9430    I VAOA(9) ]"" S VALU ES("nok",C NT,"name") =VAOA(9)
  9431   "RTN","VPR CRPC1",77, 0)
  9432    I VAOA(10 )]"" S VAL UES("nok", CNT,"relat ionship")= VAOA(10)
  9433   "RTN","VPR CRPC1",78, 0)
  9434    I VAOA(1) ]"" S VALU ES("nok",C NT,"addres s","street ",1)=VAOA( 1)
  9435   "RTN","VPR CRPC1",79, 0)
  9436    I VAOA(2) ]"" S VALU ES("nok",C NT,"addres s","street ",2)=VAOA( 2)
  9437   "RTN","VPR CRPC1",80, 0)
  9438    I VAOA(3) ]"" S VALU ES("nok",C NT,"addres s","street ",3)=VAOA( 3)
  9439   "RTN","VPR CRPC1",81, 0)
  9440    I VAOA(4) ]"" S VALU ES("nok",C NT,"addres s","city") =VAOA(4)
  9441   "RTN","VPR CRPC1",82, 0)
  9442    I VAOA(5) ]"" S VALU ES("nok",C NT,"addres s","state" )=$P(VAOA( 5),U,2)
  9443   "RTN","VPR CRPC1",83, 0)
  9444    I VAOA(6) ]"" S VALU ES("nok",C NT,"addres s","zip")= VAOA(6)
  9445   "RTN","VPR CRPC1",84, 0)
  9446    I VAOA(8) ]"" S VALU ES("nok",C NT,"addres s","phone" )=VAOA(8)
  9447   "RTN","VPR CRPC1",85, 0)
  9448    D KVAR^VA DPT
  9449   "RTN","VPR CRPC1",86, 0)
  9450    Q
  9451   "RTN","VPR CRPC1",87, 0)
  9452    ;
  9453   "RTN","VPR CRPC1",88, 0)
  9454   GETMEANS(V ALUES,DFN)  ;
  9455   "RTN","VPR CRPC1",89, 0)
  9456    D ELIG^VA DPT
  9457   "RTN","VPR CRPC1",90, 0)
  9458    I VAEL(9) ]"" S VALU ES("meanSt atus")=$P( VAEL(9),U, 2)
  9459   "RTN","VPR CRPC1",91, 0)
  9460    D KVAR^VA DPT
  9461   "RTN","VPR CRPC1",92, 0)
  9462    Q
  9463   "RTN","VPR CRPC1",93, 0)
  9464    ;
  9465   "RTN","VPR CRPC1",94, 0)
  9466   GETPATI(RE SULT,DFN)  ;
  9467   "RTN","VPR CRPC1",95, 0)
  9468    N TYPE,VA LUES,VPRER R,Y,VPRODE M,VPRSYS
  9469   "RTN","VPR CRPC1",96, 0)
  9470    S VPRSYS= $$GET^XPAR ("SYS","VP R SYSTEM N AME")
  9471   "RTN","VPR CRPC1",97, 0)
  9472    D DPT1OD^ VPRDJ00(.V ALUES)
  9473   "RTN","VPR CRPC1",98, 0)
  9474    S VALUES( "pid")=$$P ID^VPRDJFS (DFN)
  9475   "RTN","VPR CRPC1",99, 0)
  9476    ;D BUILDU ID^VPRPARA M(.VALUES, "patient", DFN)
  9477   "RTN","VPR CRPC1",100 ,0)
  9478    ;D GETDEM (.VALUES,D FN)
  9479   "RTN","VPR CRPC1",101 ,0)
  9480    D GETADD( .VALUES,DF N)
  9481   "RTN","VPR CRPC1",102 ,0)
  9482    ;F TYPE=1 ,3 D GETNO K(.VALUES, DFN,TYPE)
  9483   "RTN","VPR CRPC1",103 ,0)
  9484    D GETPATT M(.VALUES, DFN)
  9485   "RTN","VPR CRPC1",104 ,0)
  9486    ;D GETPAT VI(.VALUES ,DFN)
  9487   "RTN","VPR CRPC1",105 ,0)
  9488    D GETPATI P(.VALUES, DFN)
  9489   "RTN","VPR CRPC1",106 ,0)
  9490    D GETMEAN S(.VALUES, DFN)
  9491   "RTN","VPR CRPC1",107 ,0)
  9492    D PRF^VPR FPTC(DFN,. VALUES)
  9493   "RTN","VPR CRPC1",108 ,0)
  9494    S Y=$$CWA D^ORQPT2(D FN)
  9495   "RTN","VPR CRPC1",109 ,0)
  9496    I Y]"" S  VALUES("cw ad")=Y
  9497   "RTN","VPR CRPC1",110 ,0)
  9498    I $D(VALU ES("patien tRecordFla gs")) S VA LUES("cwad ")=$G(VALU ES("cwad") )_"F"
  9499   "RTN","VPR CRPC1",111 ,0)
  9500    ;D PTINQ^ ORWPT(.DEM ,DFN)
  9501   "RTN","VPR CRPC1",112 ,0)
  9502    ;S NUM=5, STR=""
  9503   "RTN","VPR CRPC1",113 ,0)
  9504    ;F  S NUM =$O(@DEM@( NUM)) Q:NU M'>0  D
  9505   "RTN","VPR CRPC1",114 ,0)
  9506    ;.S VALUE S("patDemD etails","t ext","\",N UM)=@DEM@( NUM)_$C(13 ,10)
  9507   "RTN","VPR CRPC1",115 ,0)
  9508    S VALUES( "success") ="true"
  9509   "RTN","VPR CRPC1",116 ,0)
  9510    D ENCODE^ VPRJSON("V ALUES","RE SULT","VPR ERR")
  9511   "RTN","VPR CRPC1",117 ,0)
  9512    I $D(VPRE RR) D
  9513   "RTN","VPR CRPC1",118 ,0)
  9514    .K RESULT  N TEMP,TX T
  9515   "RTN","VPR CRPC1",119 ,0)
  9516    .S TXT(1) ="Problem  encoding j son output ."
  9517   "RTN","VPR CRPC1",120 ,0)
  9518    .D SETERR OR^VPRUTIL S(.TEMP,.V PRERR,.TXT ,.VALUES)
  9519   "RTN","VPR CRPC1",121 ,0)
  9520    .K VPRERR  D ENCODE^ VPRJSON("T EMP","RESU LT","VPRER R")
  9521   "RTN","VPR CRPC1",122 ,0)
  9522    Q
  9523   "RTN","VPR CRPC1",123 ,0)
  9524    ;
  9525   "RTN","VPR CRPC1",124 ,0)
  9526   GETPATIP(V ALUES,DFN)  ;
  9527   "RTN","VPR CRPC1",125 ,0)
  9528    N VPRDATA
  9529   "RTN","VPR CRPC1",126 ,0)
  9530    D INPLOC^ ORWPT(.VPR DATA,DFN)
  9531   "RTN","VPR CRPC1",127 ,0)
  9532    I +VPRDAT A S VALUES ("inpatien tLocation" )=$P(VPRDA TA,U,2)
  9533   "RTN","VPR CRPC1",128 ,0)
  9534    I $P($G(^ DPT(DFN,.1 01)),U)'=" " S VALUES ("roomBed" )=$P($G(^D PT(DFN,.10 1)),U)
  9535   "RTN","VPR CRPC1",129 ,0)
  9536    Q
  9537   "RTN","VPR CRPC1",130 ,0)
  9538    ;
  9539   "RTN","VPR CRPC1",131 ,0)
  9540   GETPATVI(V ALUES,DFN)  ;
  9541   "RTN","VPR CRPC1",132 ,0)
  9542    N BMI,DAS ,HT,LDATE, VPRTEMP,WT
  9543   "RTN","VPR CRPC1",133 ,0)
  9544    ;get weig ht
  9545   "RTN","VPR CRPC1",134 ,0)
  9546    S LDATE=$ O(^PXRMIND X(120.5,"P I",DFN,9," "),-1)
  9547   "RTN","VPR CRPC1",135 ,0)
  9548    I LDATE>0  D
  9549   "RTN","VPR CRPC1",136 ,0)
  9550    .S DAS=$O (^PXRMINDX (120.5,"PI ",DFN,9,LD ATE,""))
  9551   "RTN","VPR CRPC1",137 ,0)
  9552    .I DAS']" " Q
  9553   "RTN","VPR CRPC1",138 ,0)
  9554    .D GETDAT A^PXRMVITL (DAS,.VPRT EMP)
  9555   "RTN","VPR CRPC1",139 ,0)
  9556    .S WT=VPR TEMP("VALU E")
  9557   "RTN","VPR CRPC1",140 ,0)
  9558    .S VALUES ("lastVita ls","weigh t","value" )=WT
  9559   "RTN","VPR CRPC1",141 ,0)
  9560    .S VALUES ("lastVita ls","weigh t","lastDo ne")=$$FMT E^XLFDT(LD ATE,"D")
  9561   "RTN","VPR CRPC1",142 ,0)
  9562    ;get heig ht
  9563   "RTN","VPR CRPC1",143 ,0)
  9564    K LDATE,D AS
  9565   "RTN","VPR CRPC1",144 ,0)
  9566    S LDATE=$ O(^PXRMIND X(120.5,"P I",DFN,8," "),-1)
  9567   "RTN","VPR CRPC1",145 ,0)
  9568    I LDATE>0  D
  9569   "RTN","VPR CRPC1",146 ,0)
  9570    .S DAS=$O (^PXRMINDX (120.5,"PI ",DFN,8,LD ATE,""))
  9571   "RTN","VPR CRPC1",147 ,0)
  9572    .I DAS']" " Q
  9573   "RTN","VPR CRPC1",148 ,0)
  9574    .D GETDAT A^PXRMVITL (DAS,.VPRT EMP)
  9575   "RTN","VPR CRPC1",149 ,0)
  9576    .S HT=VPR TEMP("VALU E")
  9577   "RTN","VPR CRPC1",150 ,0)
  9578    .S VALUES ("lastVita ls","heigh t","value" )=HT
  9579   "RTN","VPR CRPC1",151 ,0)
  9580    .S VALUES ("lastVita ls","heigh t","lastDo ne")=$$FMT E^XLFDT(LD ATE,"D")
  9581   "RTN","VPR CRPC1",152 ,0)
  9582    S BMI=$$G ETBMI(DFN)
  9583   "RTN","VPR CRPC1",153 ,0)
  9584    I BMI>0 S  VALUES("l astVitals" ,"bmi")=BM I
  9585   "RTN","VPR CRPC1",154 ,0)
  9586    S BSA=$$G ETBSA(DFN)
  9587   "RTN","VPR CRPC1",155 ,0)
  9588    I BSA>0 S  VALUES("l astVitals" ,"bsa")=BS A
  9589   "RTN","VPR CRPC1",156 ,0)
  9590    Q
  9591   "RTN","VPR CRPC1",157 ,0)
  9592   GETPATTM(V ALUES,DFN)  ;
  9593   "RTN","VPR CRPC1",158 ,0)
  9594    N CNT,PRO V,TEAM,MH, X,VPRTEAM
  9595   "RTN","VPR CRPC1",159 ,0)
  9596    S PROV=$$ OUTPTPR^SD UTL3(DFN)
  9597   "RTN","VPR CRPC1",160 ,0)
  9598    S TEAM=$$ OUTPTTM^SD UTL3(DFN)
  9599   "RTN","VPR CRPC1",161 ,0)
  9600    S MH=$$ST ART^SCMCMH TC(DFN)
  9601   "RTN","VPR CRPC1",162 ,0)
  9602    I PROV D
  9603   "RTN","VPR CRPC1",163 ,0)
  9604    .S VALUES ("teamInfo ","primary Provider", "name")=$P (PROV,U,2)
  9605   "RTN","VPR CRPC1",164 ,0)
  9606    .S VALUES ("teamInfo ","primary Provider", "analogPag er")=$P($G (^VA(200,+ PROV,.13)) ,U,7)
  9607   "RTN","VPR CRPC1",165 ,0)
  9608    .S VALUES ("teamInfo ","primary Provider", "digitalPa ger")=$P($ G(^VA(200, +PROV,.13) ),U,8)
  9609   "RTN","VPR CRPC1",166 ,0)
  9610    .S VALUES ("teamInfo ","primary Provider", "officelPa ger")=$P($ G(^VA(200, +PROV,.13) ),U,2)
  9611   "RTN","VPR CRPC1",167 ,0)
  9612    I 'PROV S  VALUES("t eamInfo"," primaryPro vider","na me")="unas signed"
  9613   "RTN","VPR CRPC1",168 ,0)
  9614    I TEAM D
  9615   "RTN","VPR CRPC1",169 ,0)
  9616    .S VALUES ("teamInfo ","team"," name")=$P( TEAM,U,2)
  9617   "RTN","VPR CRPC1",170 ,0)
  9618    .S VALUES ("teamInfo ","team"," phone")=$P ($G(^SCTM( 404.51,+TE AM,0)),U,2 )
  9619   "RTN","VPR CRPC1",171 ,0)
  9620    I 'TEAM S  VALUES("t eamInfo"," team","nam e")="unass igned"
  9621   "RTN","VPR CRPC1",172 ,0)
  9622    S X=$G(^D PT(DFN,.10 41))
  9623   "RTN","VPR CRPC1",173 ,0)
  9624    I +X D
  9625   "RTN","VPR CRPC1",174 ,0)
  9626    . S VALUE S("teamInf o","attend ingProvide r","name") =$P($G(^VA (200,+X,0) ),U)
  9627   "RTN","VPR CRPC1",175 ,0)
  9628    . S VALUE S("teamInf o","attend ingProvide r","analog Pager")=$P ($G(^VA(20 0,+X,.13)) ,U,7)
  9629   "RTN","VPR CRPC1",176 ,0)
  9630    . S VALUE S("teamInf o","attend ingProvide r","office lPager")=$ P($G(^VA(2 00,+X,.13) ),U,8)
  9631   "RTN","VPR CRPC1",177 ,0)
  9632    . S VALUE S("teamInf o","attend ingProvide r","office lPager")=$ P($G(^VA(2 00,+X,.13) ),U,2)
  9633   "RTN","VPR CRPC1",178 ,0)
  9634    I '+X S V ALUES("tea mInfo","at tendingPro vider","na me")="unas signed"
  9635   "RTN","VPR CRPC1",179 ,0)
  9636    I MH D
  9637   "RTN","VPR CRPC1",180 ,0)
  9638    .S VALUES ("teamInfo ","mhCoord inator","n ame")=$P(M H,U,2)
  9639   "RTN","VPR CRPC1",181 ,0)
  9640    .S VALUES ("teamInfo ","mhPosit ion")=$P(M H,U,3)
  9641   "RTN","VPR CRPC1",182 ,0)
  9642    .S VALUES ("teamInfo ","mhTeam" )=$P(MH,U, 5)
  9643   "RTN","VPR CRPC1",183 ,0)
  9644    .S VALUES ("teamInfo ","mhCoord inator","a nalogPager ")=$P($G(^ VA(200,+MH ,.13)),U,7 )
  9645   "RTN","VPR CRPC1",184 ,0)
  9646    .S VALUES ("teamInfo ","mhCoord inator","d igitalPage r")=$P($G( ^VA(200,+M H,.13)),U, 8)
  9647   "RTN","VPR CRPC1",185 ,0)
  9648    .S VALUES ("teamInfo ","mhCoord inator","o fficePhone ")=$P($G(^ VA(200,+MH ,.13)),U,2 )
  9649   "RTN","VPR CRPC1",186 ,0)
  9650    .I 'MH D
  9651   "RTN","VPR CRPC1",187 ,0)
  9652    ..S VALUE S("teamInf o","mhCoor dinator"," name")="un assigned"
  9653   "RTN","VPR CRPC1",188 ,0)
  9654    ..S VALUE S("teamInf o","mhPosi tion")="un assigned"
  9655   "RTN","VPR CRPC1",189 ,0)
  9656    ..S VALUE S("teamInf o","mhTeam ")="unassi gned"
  9657   "RTN","VPR CRPC1",190 ,0)
  9658    D PCDETAI L^ORWPT1(. VPRTEAM,DF N)
  9659   "RTN","VPR CRPC1",191 ,0)
  9660    S CNT=0 F   S CNT=$O (VPRTEAM(C NT)) Q:CNT '>0  D
  9661   "RTN","VPR CRPC1",192 ,0)
  9662    .S VALUES ("teamInfo ","text"," \",CNT)=VP RTEAM(CNT) _$C(13,10)
  9663   "RTN","VPR CRPC1",193 ,0)
  9664    Q
  9665   "RTN","VPR CRPC1",194 ,0)
  9666    ;
  9667   "RTN","VPR CRPC1",195 ,0)
  9668   GETPOS(VAL UES,USER)  ;
  9669   "RTN","VPR CRPC1",196 ,0)
  9670    ; this re turns the  list of po sition for  an user
  9671   "RTN","VPR CRPC1",197 ,0)
  9672    N CNT,NOD E,NUM,ROLE IEN,ROLE,T EAM,TEAMIE N,TEAMPHN, VPRLIST,VP RERR
  9673   "RTN","VPR CRPC1",198 ,0)
  9674    ;$$TPPR^S CAPMC(DUZ, SCDATES,SC PURPA,SCRO LEA,"LIST" ,VPRERR)
  9675   "RTN","VPR CRPC1",199 ,0)
  9676    S NUM=$$T PPR^SCAPMC (USER,""," ","","",.V PRERR)
  9677   "RTN","VPR CRPC1",200 ,0)
  9678    F CNT=1:1 :NUM D
  9679   "RTN","VPR CRPC1",201 ,0)
  9680    .S NODE=$ G(^TMP("SC  TMP LIST" ,$J,CNT))
  9681   "RTN","VPR CRPC1",202 ,0)
  9682    .S VALUES ("vistaPos itions",CN T,"positio n")=$P(NOD E,U,2)
  9683   "RTN","VPR CRPC1",203 ,0)
  9684    .S VALUES ("vistaPos itions",CN T,"effecti veDate")=$ P(NODE,U,5 )
  9685   "RTN","VPR CRPC1",204 ,0)
  9686    .S VALUES ("vistaPos itions",CN T,"inactiv eDate")=$P (NODE,U,6)
  9687   "RTN","VPR CRPC1",205 ,0)
  9688    .S TEAMIE N=$P(NODE, U,3)
  9689   "RTN","VPR CRPC1",206 ,0)
  9690    .S TEAM=$ $GET1^DIQ( 404.51,(+T EAMIEN_"," ),.01)
  9691   "RTN","VPR CRPC1",207 ,0)
  9692    .S TEAMPH N=$$GET1^D IQ(404.51, (+TEAMIEN_ ","),.02)
  9693   "RTN","VPR CRPC1",208 ,0)
  9694    .S VALUES ("vistaPos itions",CN T,"teamNam e")=TEAM
  9695   "RTN","VPR CRPC1",209 ,0)
  9696    .S VALUES ("vistaPos itions",CN T,"teamPho ne")=TEAMP HN
  9697   "RTN","VPR CRPC1",210 ,0)
  9698    .I $P(NOD E,U,9)>0 D
  9699   "RTN","VPR CRPC1",211 ,0)
  9700    .S VALUES ("vistaPos itions",CN T,"role")= $$GET1^DIQ (8930,($P( NODE,U,9)_ ","),.01)
  9701   "RTN","VPR CRPC1",212 ,0)
  9702    Q
  9703   "RTN","VPR CRPC1",213 ,0)
  9704    ;
  9705   "RTN","VPR CRPC1",214 ,0)
  9706   GETUSERC(V ALUES,USER ) ;
  9707   "RTN","VPR CRPC1",215 ,0)
  9708    N ARRAY,C NT,EFFDATE ,EXPDATE,I D,IND,LIST ,NODE
  9709   "RTN","VPR CRPC1",216 ,0)
  9710    D WHATIS^ USRLM(USER ,"LIST",1)
  9711   "RTN","VPR CRPC1",217 ,0)
  9712    ;LIST(Upp ername_ind icator)=Us erClassIEN ^Membershi pIEN^name^ EffectDt^E xpireDt
  9713   "RTN","VPR CRPC1",218 ,0)
  9714    S IND=0,C NT=0 F  S  IND=$O(LIS T(IND)) Q: IND=""  D
  9715   "RTN","VPR CRPC1",219 ,0)
  9716    .S NODE=L IST(IND)
  9717   "RTN","VPR CRPC1",220 ,0)
  9718    .S EFFDAT E=$P(NODE, U,4),EXPDA TE=$P(NODE ,U,5)
  9719   "RTN","VPR CRPC1",221 ,0)
  9720    .I EFFDAT E>0,EFFDAT E>DT Q
  9721   "RTN","VPR CRPC1",222 ,0)
  9722    .I EXPDAT E>0,EXPDAT E<DT Q
  9723   "RTN","VPR CRPC1",223 ,0)
  9724    .S CNT=CN T+1
  9725   "RTN","VPR CRPC1",224 ,0)
  9726    .S ID=$P( NODE,U)
  9727   "RTN","VPR CRPC1",225 ,0)
  9728    .S ARRAY( ID)=""
  9729   "RTN","VPR CRPC1",226 ,0)
  9730    .S VALUES ("vistaUse rClass",CN T,"role")= $P(NODE,U, 3)
  9731   "RTN","VPR CRPC1",227 ,0)
  9732    .S VALUES ("vistaUse rClass",CN T,"uid")=$ $SETUID^VP RUTILS("as u-class"," ",ID,"")
  9733   "RTN","VPR CRPC1",228 ,0)
  9734    .S VALUES ("vistaUse rClass",CN T,"effecti veDate")=E FFDATE
  9735   "RTN","VPR CRPC1",229 ,0)
  9736    .S VALUES ("vistaUse rClass",CN T,"expirat ionDate")= EXPDATE
  9737   "RTN","VPR CRPC1",230 ,0)
  9738    .I $D(^US R(8930,"AD ",ID)) D G ETUCPAR(.V ALUES,ID,. CNT,.ARRAY )
  9739   "RTN","VPR CRPC1",231 ,0)
  9740    I CNT=0 D
  9741   "RTN","VPR CRPC1",232 ,0)
  9742    .S ID=$O( ^USR(8930, "B","USER" ,"")) I +I D'>0 Q
  9743   "RTN","VPR CRPC1",233 ,0)
  9744    .S CNT=CN T+1
  9745   "RTN","VPR CRPC1",234 ,0)
  9746    .S VALUES ("vistaUse rClass",CN T,"role")= $P($G(^USR (8930,ID,0 )),U)
  9747   "RTN","VPR CRPC1",235 ,0)
  9748    .S VALUES ("vistaUse rClass",CN T,"uid")=$ $SETUID^VP RUTILS("as u-class"," ",ID,"")
  9749   "RTN","VPR CRPC1",236 ,0)
  9750    Q
  9751   "RTN","VPR CRPC1",237 ,0)
  9752   GETUCPAR(V ALUES,ID,C NT,ARRAY)  ;
  9753   "RTN","VPR CRPC1",238 ,0)
  9754    N IEN,ROL E
  9755   "RTN","VPR CRPC1",239 ,0)
  9756    S IEN=0 F   S IEN=$O (^USR(8930 ,"AD",ID,I EN)) Q:IEN '>0  D
  9757   "RTN","VPR CRPC1",240 ,0)
  9758    .I $D(ARR AY(IEN)) Q
  9759   "RTN","VPR CRPC1",241 ,0)
  9760    .S ARRAY( IEN)=""
  9761   "RTN","VPR CRPC1",242 ,0)
  9762    .S ROLE=$ P($G(^USR( 8930,IEN,0 )),U)
  9763   "RTN","VPR CRPC1",243 ,0)
  9764    .S CNT=CN T+1
  9765   "RTN","VPR CRPC1",244 ,0)
  9766    .S VALUES ("vistaUse rClass",CN T,"role")= ROLE
  9767   "RTN","VPR CRPC1",245 ,0)
  9768    .S VALUES ("vistaUse rClass",CN T,"uid")=$ $SETUID^VP RUTILS("as u-class"," ",IEN,"")
  9769   "RTN","VPR CRPC1",246 ,0)
  9770    .I $D(^US R(8930,"AD ",ID)) D G ETUCPAR(.V ALUES,IEN, .CNT,.ARRA Y)
  9771   "RTN","VPR CRPC1",247 ,0)
  9772    Q
  9773   "RTN","VPR CRPC1",248 ,0)
  9774    ;
  9775   "RTN","VPR CRPC1",249 ,0)
  9776   GETUSERI(R ESULT,USER ) ;
  9777   "RTN","VPR CRPC1",250 ,0)
  9778    N RPCOPT, VALUES,VPR ERR,VPRLIS T
  9779   "RTN","VPR CRPC1",251 ,0)
  9780    D BUILDUI D^VPRPARAM (.VALUES," user",USER )
  9781   "RTN","VPR CRPC1",252 ,0)
  9782    S VALUES( "timeout") =$$GET^XPA R("USR^SYS ","ORWOR T IMEOUT CHA RT",1,"I")
  9783   "RTN","VPR CRPC1",253 ,0)
  9784    S VALUES( "timeoutCo unter")=$$ GET^XPAR(" USR^SYS^PK G","ORWOR  TIMEOUT CO UNTDOWN",1 ,"I")
  9785   "RTN","VPR CRPC1",254 ,0)
  9786    S CPRSPAT H=$$GET^XP AR("USR^SY S","VPR CP RS PATH",1 ,"I")
  9787   "RTN","VPR CRPC1",255 ,0)
  9788    S VALUES( "cprsPath" )=$S($L($G (CPRSPATH) )>0:CPRSPA TH,1:"")
  9789   "RTN","VPR CRPC1",256 ,0)
  9790    D FIND^DI C(19,"",1, "X","VPR U I CONTEXT" ,1,,,,"VPR LIST")
  9791   "RTN","VPR CRPC1",257 ,0)
  9792    S RPCOPT= $S($D(^VPR LIST("DILI ST",0)):-1 ,1:$P(VPRL IST("DILIS T","ID",1, 1),"versio n ",2))
  9793   "RTN","VPR CRPC1",258 ,0)
  9794    ;S VALUES ("signingP riv")=$S($ D(^XUSEC(" ORES",DUZ) ):3,$D(^XU SEC("ORELS E",DUZ)):2 ,$D(^XUSEC ("OREMAS", DUZ)):1,1: 0)
  9795   "RTN","VPR CRPC1",259 ,0)
  9796    S VALUES( "orderingR ole")=$$OR DROLE(USER )
  9797   "RTN","VPR CRPC1",260 ,0)
  9798    S VALUES( "hmpVersio n")=RPCOPT
  9799   "RTN","VPR CRPC1",261 ,0)
  9800    S VALUES( "domain")= $$KSP^XUPA RAM("WHERE ")  ; doma in
  9801   "RTN","VPR CRPC1",262 ,0)
  9802    S VALUES( "service") =+$G(^VA(2 00,USER,5) )     ; se rvice/sect ion
  9803   "RTN","VPR CRPC1",263 ,0)
  9804    D GETUSER C(.VALUES, USER)
  9805   "RTN","VPR CRPC1",264 ,0)
  9806    D GETPOS( .VALUES,US ER)
  9807   "RTN","VPR CRPC1",265 ,0)
  9808    D GETKEYS (.VALUES,U SER)
  9809   "RTN","VPR CRPC1",266 ,0)
  9810    S VALUES( "productio nAccount") =$S($$PROD ^XUPROD=1: "true",1:" false")
  9811   "RTN","VPR CRPC1",267 ,0)
  9812    ;S RESULT =$$ENCODE^ VPRJSON("V ALUES","VP RERR")
  9813   "RTN","VPR CRPC1",268 ,0)
  9814    D ENCODE^ VPRJSON("V ALUES","RE SULT","VPR ERR")
  9815   "RTN","VPR CRPC1",269 ,0)
  9816    Q
  9817   "RTN","VPR CRPC1",270 ,0)
  9818    ;
  9819   "RTN","VPR CRPC1",271 ,0)
  9820   ORDROLE(US ER) ; retu rns the ro le a perso n takes in  ordering
  9821   "RTN","VPR CRPC1",272 ,0)
  9822    ; VAL: 0= nokey, 1=c lerk, 2=nu rse, 3=phy sician, 4= student, 5 =bad keys
  9823   "RTN","VPR CRPC1",273 ,0)
  9824    ;I '$G(OR WCLVER) Q  0  ; versi on of clie nt is to o ld for ord ering
  9825   "RTN","VPR CRPC1",274 ,0)
  9826    I ($D(^XU SEC("OREMA S",USER))+ $D(^XUSEC( "ORELSE",U SER))+$D(^ XUSEC("ORE S",USER))) >1 Q 5
  9827   "RTN","VPR CRPC1",275 ,0)
  9828    I $D(^XUS EC("OREMAS ",USER)) Q  1                             ;  clerk
  9829   "RTN","VPR CRPC1",276 ,0)
  9830    I $D(^XUS EC("ORELSE ",USER)) Q  2                             ;  nurse
  9831   "RTN","VPR CRPC1",277 ,0)
  9832    I $D(^XUS EC("ORES", USER)),$D( ^XUSEC("PR OVIDER",US ER)) Q 3   ; doctor
  9833   "RTN","VPR CRPC1",278 ,0)
  9834    I $D(^XUS EC("PROVID ER",USER))  Q 4                           ;  student
  9835   "RTN","VPR CRPC1",279 ,0)
  9836    Q 0
  9837   "RTN","VPR CRPC1",280 ,0)
  9838    ;
  9839   "RTN","VPR DJ")
  9840   0^68^B3355 2080
  9841   "RTN","VPR DJ",1,0)
  9842   VPRDJ ;SLC /MKB -- Se rve VistA  data as JS ON via RPC  ;10/18/12  6:26pm
  9843   "RTN","VPR DJ",2,0)
  9844    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  9845   "RTN","VPR DJ",3,0)
  9846    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  9847   "RTN","VPR DJ",4,0)
  9848    ;
  9849   "RTN","VPR DJ",5,0)
  9850    ; Externa l Referenc es           DBIA#
  9851   "RTN","VPR DJ",6,0)
  9852    ; ------- ---------- --           -----
  9853   "RTN","VPR DJ",7,0)
  9854    ; ^DPT                            10035
  9855   "RTN","VPR DJ",8,0)
  9856    ; MPIF001                          2701
  9857   "RTN","VPR DJ",9,0)
  9858    ; XLFDT                           10103
  9859   "RTN","VPR DJ",10,0)
  9860    ; XLFSTR                          10104
  9861   "RTN","VPR DJ",11,0)
  9862    ; XUPARAM                          2541
  9863   "RTN","VPR DJ",12,0)
  9864    ;
  9865   "RTN","VPR DJ",13,0)
  9866   GET(VPR,FI LTER) ; --  Return se arch resul ts as JSON  in @VPR@( n)
  9867   "RTN","VPR DJ",14,0)
  9868    ; RPC = V PR GET PAT IENT DATA  JSON
  9869   "RTN","VPR DJ",15,0)
  9870    ; where F ILTER("pat ientId") =  DFN or DF N;ICN
  9871   "RTN","VPR DJ",16,0)
  9872    ;       F ILTER("dom ain")    =  name of d esired dat a type  (s ee VPRDJ0)
  9873   "RTN","VPR DJ",17,0)
  9874    ;       F ILTER("tex t")      =  boolean,  to include  document  text [opt]
  9875   "RTN","VPR DJ",18,0)
  9876    ;       F ILTER("sta rt")     =  start dat e.time of  search          [opt]
  9877   "RTN","VPR DJ",19,0)
  9878    ;       F ILTER("sto p")      =  stop date .time of s earch           [opt]
  9879   "RTN","VPR DJ",20,0)
  9880    ;       F ILTER("max ")       =  maximum n umber of i tems to re turn [opt]
  9881   "RTN","VPR DJ",21,0)
  9882    ;       F ILTER("id" )        =  single it em id to r eturn           [opt]
  9883   "RTN","VPR DJ",22,0)
  9884    ;       F ILTER("uid ")       =  single re cord uid t o return        [opt]
  9885   "RTN","VPR DJ",23,0)
  9886    ;       F ILTER("noH ead")    =  flag, to  omit heade r and comm as   [opt]
  9887   "RTN","VPR DJ",24,0)
  9888    ;
  9889   "RTN","VPR DJ",25,0)
  9890    N ICN,DFN ,VPRI,VPRS YS,VPRTYPE ,VPRSTART, VPRSTOP,VP RMAX,VPRID ,VPRTEXT,V PRP,TYPE,V PRTN,VPRER R
  9891   "RTN","VPR DJ",26,0)
  9892    S VPR=$NA (^TMP("VPR ",$J)),VPR I=0 K @VPR
  9893   "RTN","VPR DJ",27,0)
  9894    S VPRSYS= $$GET^XPAR ("SYS","VP R SYSTEM N AME")
  9895   "RTN","VPR DJ",28,0)
  9896    S DT=$$DT ^XLFDT              ; for crossi ng midnigh t boundary
  9897   "RTN","VPR DJ",29,0)
  9898    ;
  9899   "RTN","VPR DJ",30,0)
  9900    ; parse &  validate  input para meters
  9901   "RTN","VPR DJ",31,0)
  9902    I $G(FILT ER("uid")) '="" D SEP UID(.FILTE R)
  9903   "RTN","VPR DJ",32,0)
  9904    S DFN=$G( FILTER("pa tientId"))
  9905   "RTN","VPR DJ",33,0)
  9906    S ICN=+$P ($G(DFN)," ;",2),DFN= +$G(DFN)
  9907   "RTN","VPR DJ",34,0)
  9908    I DFN<1,I CN S DFN=+ $$GETDFN^M PIF001(ICN )
  9909   "RTN","VPR DJ",35,0)
  9910    ;
  9911   "RTN","VPR DJ",36,0)
  9912    S VPRTYPE =$G(FILTER ("domain") ) S:VPRTYP E="" VPRTY PE=$$ALL
  9913   "RTN","VPR DJ",37,0)
  9914    I $D(ZTQU EUED) S VP R=$NA(^XTM P(VPRBATCH ,VPRFZTSK, VPRTYPE))  K @VPR
  9915   "RTN","VPR DJ",38,0)
  9916    I VPRTYPE '="new",DF N<1!'$D(^D PT(DFN)) S  VPRERR=$$ ERR(1,DFN)  G GTQ
  9917   "RTN","VPR DJ",39,0)
  9918    ;
  9919   "RTN","VPR DJ",40,0)
  9920    S VPRSTAR T=+$G(FILT ER("start" ),1410102)
  9921   "RTN","VPR DJ",41,0)
  9922    S VPRSTOP =+$G(FILTE R("stop"), 4141015)
  9923   "RTN","VPR DJ",42,0)
  9924    S VPRMAX= +$G(FILTER ("max"),99 9999)
  9925   "RTN","VPR DJ",43,0)
  9926    I VPRSTAR T,VPRSTOP, VPRSTOP<VP RSTART D
  9927   "RTN","VPR DJ",44,0)
  9928    . N X S X =VPRSTART, VPRSTART=V PRSTOP,VPR STOP=X
  9929   "RTN","VPR DJ",45,0)
  9930    I VPRSTOP ,$L(VPRSTO P,".")<2 S  VPRSTOP=V PRSTOP_".2 4"
  9931   "RTN","VPR DJ",46,0)
  9932    ;
  9933   "RTN","VPR DJ",47,0)
  9934    S VPRID=$ G(FILTER(" id"))
  9935   "RTN","VPR DJ",48,0)
  9936    S VPRTEXT =+$G(FILTE R("text"), 1) ;defaul t = true/t ext
  9937   "RTN","VPR DJ",49,0)
  9938    ;
  9939   "RTN","VPR DJ",50,0)
  9940    ;set erro r trap
  9941   "RTN","VPR DJ",51,0)
  9942    K ^TMP($J ,"VPR ERRO R")
  9943   "RTN","VPR DJ",52,0)
  9944    ;
  9945   "RTN","VPR DJ",53,0)
  9946    ; extract  data
  9947   "RTN","VPR DJ",54,0)
  9948    I VPRTYPE ="new",$L( $T(EN^VPRD JX)),'$G(^ XTMP("VPR- off","GET" )) D EN^VP RDJX(VPRID ,VPRMAX) Q   ;data up dates
  9949   "RTN","VPR DJ",55,0)
  9950    F VPRP=1: 1:$L(VPRTY PE,";") S  TYPE=$P(VP RTYPE,";", VPRP) I $L (TYPE) D
  9951   "RTN","VPR DJ",56,0)
  9952    . S VPRTN =$$TAG(TYP E)_"^VPRDJ 0" Q:'$L($ T(@VPRTN))   ;D ERR(2 ) Q
  9953   "RTN","VPR DJ",57,0)
  9954    . N $ES,$ ET,ERRPAT, ERRMSG
  9955   "RTN","VPR DJ",58,0)
  9956    . S $ET=" D ERRHDLR^ VPRDERRH", ERRMSG="A  problem oc curred whe n trying t o load pat ient data  from an AP I."
  9957   "RTN","VPR DJ",59,0)
  9958    . D @VPRT N
  9959   "RTN","VPR DJ",60,0)
  9960    ;
  9961   "RTN","VPR DJ",61,0)
  9962   GTQ ; add  item count  and termi nating cha racters
  9963   "RTN","VPR DJ",62,0)
  9964    N ERROR I  $D(^TMP($ J,"VPR ERR OR"))>0 D  BUILDERR(. ERROR)
  9965   "RTN","VPR DJ",63,0)
  9966    I +$G(FIL TER("noHea d"))=1 D   Q
  9967   "RTN","VPR DJ",64,0)
  9968    .S @VPR@( "total")=+ $G(VPRI)
  9969   "RTN","VPR DJ",65,0)
  9970    .I $L($G( ERROR(1))) >1 S @VPR@ ("error")= ERROR(1)
  9971   "RTN","VPR DJ",66,0)
  9972    S @VPR@(. 5)="{""api Version"": ""1.01""," "params"": {"_$$SYS_" },"
  9973   "RTN","VPR DJ",67,0)
  9974    I $D(VPRE RR) S @VPR @(1)="""er ror"":{""m essage"":" ""_VPRERR_ """}}" Q
  9975   "RTN","VPR DJ",68,0)
  9976    I '$D(@VP R)!'$G(VPR I) D  Q
  9977   "RTN","VPR DJ",69,0)
  9978    . I '$D(E RROR) S @V PR@(1)=""" data"":{"" totalItems "":0,""ite ms"":[]}}"  Q
  9979   "RTN","VPR DJ",70,0)
  9980    . S @VPR@ (1)="""dat a"":{""tot alItems"": 0,""items" ":[]},"
  9981   "RTN","VPR DJ",71,0)
  9982    . S @VPR@ (2,1)=ERRO R(1)_"}"
  9983   "RTN","VPR DJ",72,0)
  9984    ;
  9985   "RTN","VPR DJ",73,0)
  9986    S @VPR@(. 6)="""data "":{""upda ted"":"""_ $$HL7NOW_" "",""total Items"":"_ VPRI_",""i tems"":["
  9987   "RTN","VPR DJ",74,0)
  9988    S VPRI=VP RI+1,@VPR@ (VPRI)=$S( $D(ERROR): "]}",1:"]} }")
  9989   "RTN","VPR DJ",75,0)
  9990    I $D(ERRO R)>0 S VPR I=VPRI+1,@ VPR@(VPRI, .3)=",",@V PR@(VPRI,1 )=ERROR(1) _"}"
  9991   "RTN","VPR DJ",76,0)
  9992    K ^TMP($J ,"VPR ERRO R"),^TMP(" VPRTEXT",$ J)
  9993   "RTN","VPR DJ",77,0)
  9994    Q
  9995   "RTN","VPR DJ",78,0)
  9996    ;
  9997   "RTN","VPR DJ",79,0)
  9998   SEPUID(FIL TER) ; --  separate u id into FI LTER piece s
  9999   "RTN","VPR DJ",80,0)
  10000    N UID
  10001   "RTN","VPR DJ",81,0)
  10002    S UID=$G( FILTER("ui d")) K FIL TER("uid")  Q:UID=""
  10003   "RTN","VPR DJ",82,0)
  10004    I $P(UID, ":",4)'=VP RSYS Q
  10005   "RTN","VPR DJ",83,0)
  10006    S FILTER( "patientId ")=$P(UID, ":",5)
  10007   "RTN","VPR DJ",84,0)
  10008    S FILTER( "domain")= $P(UID,":" ,3)
  10009   "RTN","VPR DJ",85,0)
  10010    S FILTER( "id")=$P(U ID,":",6)
  10011   "RTN","VPR DJ",86,0)
  10012    Q
  10013   "RTN","VPR DJ",87,0)
  10014    ;
  10015   "RTN","VPR DJ",88,0)
  10016   SYS() ; --  return sy stem info  for JSON h eader
  10017   "RTN","VPR DJ",89,0)
  10018    Q """doma in"":"""_$ $KSP^XUPAR AM("WHERE" )_""",""sy stemId"":" ""_VPRSYS_ """"
  10019   "RTN","VPR DJ",90,0)
  10020    ;
  10021   "RTN","VPR DJ",91,0)
  10022   BUILDERR(R ESULT,DFN)  ; -- buil d error ar ray
  10023   "RTN","VPR DJ",92,0)
  10024    N COUNT,M ESSAGE,MSG CNT
  10025   "RTN","VPR DJ",93,0)
  10026    S COUNT=$ G(^TMP($J, "VPR ERROR ","# of Er rors"))
  10027   "RTN","VPR DJ",94,0)
  10028    S MESSAGE ="A mumps  error occu rred when  extracting  patient d ata. A tot al of "_CO UNT_" occu rred.\n\r"
  10029   "RTN","VPR DJ",95,0)
  10030    S MSGCNT= 0 F  S MSG CNT=$O(^TM P($J,"VPR  ERROR","ER ROR MESSAG E",MSGCNT) ) Q:MSGCNT '>0  D
  10031   "RTN","VPR DJ",96,0)
  10032    . S MESSA GE=MESSAGE _$G(^TMP($ J,"VPR ERR OR","ERROR  MESSAGE", MSGCNT))_" \n\r"
  10033   "RTN","VPR DJ",97,0)
  10034    S RESULT( 1)="""erro r"":{""mes sage"":""" _MESSAGE_" ""}"
  10035   "RTN","VPR DJ",98,0)
  10036    Q
  10037   "RTN","VPR DJ",99,0)
  10038    ;
  10039   "RTN","VPR DJ",100,0)
  10040   TAG(X) ; - - Return l inetag in  VPRDJ0 rou tine for c linical do main X
  10041   "RTN","VPR DJ",101,0)
  10042    N Y S X=$ G(X,"Z")
  10043   "RTN","VPR DJ",102,0)
  10044    S Y=$E($$ UP^XLFSTR( X),1,8)
  10045   "RTN","VPR DJ",103,0)
  10046    S:'$L($T( @(Y_"^VPRD J0"))) Y=" VPR"
  10047   "RTN","VPR DJ",104,0)
  10048    Q Y
  10049   "RTN","VPR DJ",105,0)
  10050    ;
  10051   "RTN","VPR DJ",106,0)
  10052   ALL() ; --  return st ring for a ll types o f data
  10053   "RTN","VPR DJ",107,0)
  10054    Q "patien t;problem; allergy;co nsult;vita l;lab;proc edure;obs; order;trea tment;med; ptf;factor ;immunizat ion;exam;c pt;educati on;pov;ski n;image;ap pointment; surgery;do cument;vis it;mh"
  10055   "RTN","VPR DJ",108,0)
  10056    ;
  10057   "RTN","VPR DJ",109,0)
  10058   ERR(X,VAL)  ; -- retu rn error m essage
  10059   "RTN","VPR DJ",110,0)
  10060    N MSG  S  MSG="Error "
  10061   "RTN","VPR DJ",111,0)
  10062    I X=1  S  MSG="Patie nt with df n '"_$G(VA L)_"' not  found"
  10063   "RTN","VPR DJ",112,0)
  10064    I X=2  S  MSG="Domai n type '"_ $G(VAL)_"'  not recog nized"
  10065   "RTN","VPR DJ",113,0)
  10066    I X=3  S  MSG="UID ' "_$G(VAL)_ "' not fou nd"
  10067   "RTN","VPR DJ",114,0)
  10068    I X=4  S  MSG="Unabl e to creat e new obje ct"
  10069   "RTN","VPR DJ",115,0)
  10070    I X=99 S  MSG="Unkno wn request "
  10071   "RTN","VPR DJ",116,0)
  10072    Q MSG
  10073   "RTN","VPR DJ",117,0)
  10074    ;
  10075   "RTN","VPR DJ",118,0)
  10076   HL7NOW() ;  -- Return  current t ime in HL7  format
  10077   "RTN","VPR DJ",119,0)
  10078    Q $P($$FM THL7^XLFDT ($$NOW^XLF DT),"-")
  10079   "RTN","VPR DJ",120,0)
  10080    ;
  10081   "RTN","VPR DJ",121,0)
  10082   ADD(ITEM,C OLL) ; --  add ITEM t o results
  10083   "RTN","VPR DJ",122,0)
  10084    I $D(VPRC RC),$D(COL L) D ONE^V PRDCRC(ITE M,COLL) Q   ;checksum
  10085   "RTN","VPR DJ",123,0)
  10086    ; -- add  ITEM to @V PR@(VPRI)  to return  JSON
  10087   "RTN","VPR DJ",124,0)
  10088    N VPRY,VP RERR
  10089   "RTN","VPR DJ",125,0)
  10090    D ENCODE^ VPRJSON(IT EM,"VPRY", "VPRERR")
  10091   "RTN","VPR DJ",126,0)
  10092    I $D(VPRE RR) D  ;re turn ERRor  instead o f ITEM
  10093   "RTN","VPR DJ",127,0)
  10094    . N VPRTM P,VPRTXT,V PRITM
  10095   "RTN","VPR DJ",128,0)
  10096    . M VPRIT M=@ITEM K  VPRY
  10097   "RTN","VPR DJ",129,0)
  10098    . S VPRTX T(1)="Prob lem encodi ng json ou tput."
  10099   "RTN","VPR DJ",130,0)
  10100    . D SETER ROR^VPRUTI LS(.VPRTMP ,.VPRERR,. VPRTXT,.VP RITM)
  10101   "RTN","VPR DJ",131,0)
  10102    . K VPRER R D ENCODE ^VPRJSON(" VPRTMP","V PRY","VPRE RR")
  10103   "RTN","VPR DJ",132,0)
  10104    I $D(VPRY ) D
  10105   "RTN","VPR DJ",133,0)
  10106    . S VPRI= VPRI+1
  10107   "RTN","VPR DJ",134,0)
  10108    . ;I VPRI >1,'$G(FIL TER("noHea d")) S @VP R@(VPRI,.3 )=","
  10109   "RTN","VPR DJ",135,0)
  10110    . I VPRI> 1 S @VPR@( VPRI,.3)=" ,"
  10111   "RTN","VPR DJ",136,0)
  10112    . M @VPR@ (VPRI)=VPR Y
  10113   "RTN","VPR DJ",137,0)
  10114    Q
  10115   "RTN","VPR DJ",138,0)
  10116    ;
  10117   "RTN","VPR DJ",139,0)
  10118   TEST(DFN,T YPE,ID,TEX T,IN) ; --  test GET,  write res ults to sc reen
  10119   "RTN","VPR DJ",140,0)
  10120    N OUT,IDX  S U="^"
  10121   "RTN","VPR DJ",141,0)
  10122    S:'$D(IN( "systemID" )) IN("sys temID")=$$ GET^XPAR(" SYS","VPR  SYSTEM NAM E")
  10123   "RTN","VPR DJ",142,0)
  10124    S IN("pat ientId")=+ $G(DFN)
  10125   "RTN","VPR DJ",143,0)
  10126    S IN("dom ain")=$G(T YPE)
  10127   "RTN","VPR DJ",144,0)
  10128    S:$D(ID)  IN("id")=I D
  10129   "RTN","VPR DJ",145,0)
  10130    S:$D(TEXT ) IN("text ")=TEXT
  10131   "RTN","VPR DJ",146,0)
  10132    D GET(.OU T,.IN)
  10133   "RTN","VPR DJ",147,0)
  10134    ;
  10135   "RTN","VPR DJ",148,0)
  10136    S IDX=OUT
  10137   "RTN","VPR DJ",149,0)
  10138    F  S IDX= $Q(@IDX) Q :IDX'?1"^T MP(""VPR"" ,"1.N.E  Q :+$P(IDX," ,",2)'=$J   W !,@IDX
  10139   "RTN","VPR DJ",150,0)
  10140    Q
  10141   "RTN","VPR DJ0")
  10142   0^100^B875 35759
  10143   "RTN","VPR DJ0",1,0)
  10144   VPRDJ0 ;SL C/MKB -- S erve VistA  data as J SON cont ; 6/25/12  1 6:11
  10145   "RTN","VPR DJ0",2,0)
  10146    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  10147   "RTN","VPR DJ0",3,0)
  10148    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  10149   "RTN","VPR DJ0",4,0)
  10150    ;
  10151   "RTN","VPR DJ0",5,0)
  10152    ; Externa l Referenc es           DBIA#
  10153   "RTN","VPR DJ0",6,0)
  10154    ; ------- ---------- --           -----
  10155   "RTN","VPR DJ0",7,0)
  10156    ; ^DPT                            10035  < see VPRDJ0 * for othe rs>
  10157   "RTN","VPR DJ0",8,0)
  10158    ;
  10159   "RTN","VPR DJ0",9,0)
  10160    ; All tag s expect D FN, VPRSTA RT, VPRSTO P, VPRMAX,  VPRID, VP RTEXT
  10161   "RTN","VPR DJ0",10,0)
  10162    ;
  10163   "RTN","VPR DJ0",11,0)
  10164   PATIENT ;  -- Patient  Registrat ion
  10165   "RTN","VPR DJ0",12,0)
  10166    D DPT1^VP RDJ00
  10167   "RTN","VPR DJ0",13,0)
  10168    Q
  10169   "RTN","VPR DJ0",14,0)
  10170    ;
  10171   "RTN","VPR DJ0",15,0)
  10172   PROBLEM ;  -- Problem  List
  10173   "RTN","VPR DJ0",16,0)
  10174    I $G(VPRI D) D GMPL1 ^VPRDJ02(V PRID) Q
  10175   "RTN","VPR DJ0",17,0)
  10176    N ID,VPRS TS,VPRPROB ,VPRN,X
  10177   "RTN","VPR DJ0",18,0)
  10178    S VPRSTS= $G(FILTER( "status"))  ;default  = all prob lems
  10179   "RTN","VPR DJ0",19,0)
  10180    D LIST^GM PLUTL2(.VP RPROB,DFN, VPRSTS)
  10181   "RTN","VPR DJ0",20,0)
  10182    S VPRN=0  F  S VPRN= $O(VPRPROB (VPRN)) Q: (VPRN<1)!( VPRI'<VPRM AX)  D
  10183   "RTN","VPR DJ0",21,0)
  10184    . S X=$P( VPRPROB(VP RN),U,6) I  X,(X<VPRS TART)!(X>V PRSTOP) Q   ;last upd ated
  10185   "RTN","VPR DJ0",22,0)
  10186    . S ID=+V PRPROB(VPR N) D GMPL1 ^VPRDJ02(I D)
  10187   "RTN","VPR DJ0",23,0)
  10188    Q
  10189   "RTN","VPR DJ0",24,0)
  10190    ;
  10191   "RTN","VPR DJ0",25,0)
  10192   ALLERGY ;  -- Allergi es/Adverse  Reactions
  10193   "RTN","VPR DJ0",26,0)
  10194    N GMRAL,I D D EN1^GM RADPT
  10195   "RTN","VPR DJ0",27,0)
  10196    I 'GMRAL  Q  ;D NKA^ VPRDJ02 Q
  10197   "RTN","VPR DJ0",28,0)
  10198    I $G(VPRI D) D GMRA1 ^VPRDJ02(V PRID) Q
  10199   "RTN","VPR DJ0",29,0)
  10200    S ID=0 F   S ID=+$O( GMRAL(ID))  Q:ID<1  D  GMRA1^VPR DJ02(ID) Q :VPRI'<VPR MAX
  10201   "RTN","VPR DJ0",30,0)
  10202    Q
  10203   "RTN","VPR DJ0",31,0)
  10204    ;
  10205   "RTN","VPR DJ0",32,0)
  10206   CONSULT ;  -- Consult /Request T racking
  10207   "RTN","VPR DJ0",33,0)
  10208    N VPRN,VP RX,ID
  10209   "RTN","VPR DJ0",34,0)
  10210    D OER^GMR CSLM1(DFN, "",VPRSTAR T,VPRSTOP, "")
  10211   "RTN","VPR DJ0",35,0)
  10212    S VPRN=0  F  S VPRN= $O(^TMP("G MRCR",$J," CS",VPRN))  Q:VPRN<1! (VPRN>VPRM AX)  S VPR X=$G(^(VPR N,0)) Q:$E (VPRX)="<"   D
  10213   "RTN","VPR DJ0",36,0)
  10214    . I $G(VP RID),VPRID '=+VPRX Q
  10215   "RTN","VPR DJ0",37,0)
  10216    . D GMRC1 ^VPRDJ03(+ VPRX)
  10217   "RTN","VPR DJ0",38,0)
  10218    K ^TMP("G MRCR",$J," CS")
  10219   "RTN","VPR DJ0",39,0)
  10220    Q
  10221   "RTN","VPR DJ0",40,0)
  10222    ;
  10223   "RTN","VPR DJ0",41,0)
  10224   VITAL ; --  GMR Vital  Measureme nts
  10225   "RTN","VPR DJ0",42,0)
  10226    I $L($G(V PRID)) D G MV1^VPRDJ0 2(VPRID) Q
  10227   "RTN","VPR DJ0",43,0)
  10228    N GMRVSTR ,VPRIDT,VP RTYP,ID
  10229   "RTN","VPR DJ0",44,0)
  10230    S GMRVSTR ="BP;T;R;P ;HT;WT;CVP ;CG;PO2;PN "
  10231   "RTN","VPR DJ0",45,0)
  10232    S GMRVSTR (0)=VPRSTA RT_U_VPRST OP_U_VPRMA X_"^1"
  10233   "RTN","VPR DJ0",46,0)
  10234    D EN1^GMR VUT0
  10235   "RTN","VPR DJ0",47,0)
  10236    S VPRIDT= 0 F  S VPR IDT=$O(^UT ILITY($J," GMRVD",VPR IDT)) Q:VP RIDT<1  D   Q:VPRI'<V PRMAX
  10237   "RTN","VPR DJ0",48,0)
  10238    . S VPRTY P="" F  S  VPRTYP=$O( ^UTILITY($ J,"GMRVD", VPRIDT,VPR TYP)) Q:VP RTYP=""  D
  10239   "RTN","VPR DJ0",49,0)
  10240    .. S ID=$ O(^UTILITY ($J,"GMRVD ",VPRIDT,V PRTYP,0))  D GMV1^VPR DJ02(ID)
  10241   "RTN","VPR DJ0",50,0)
  10242    K ^UTILIT Y($J,"GMRV D")
  10243   "RTN","VPR DJ0",51,0)
  10244    Q
  10245   "RTN","VPR DJ0",52,0)
  10246    ;
  10247   "RTN","VPR DJ0",53,0)
  10248   CHEM D CH^ VPRDJ06X Q
  10249   "RTN","VPR DJ0",54,0)
  10250   LAB ; -- L ab Results
  10251   "RTN","VPR DJ0",55,0)
  10252    N LRDFN,L RID,VPRSUB ,VPRIDT,VP RN,VPRP,VP RACC,BEG,E ND,SUB,ORP K,ID,X
  10253   "RTN","VPR DJ0",56,0)
  10254    S LRDFN=$ G(^DPT(DFN ,"LR")),VP RSUB=$G(FI LTER("cate gory"))
  10255   "RTN","VPR DJ0",57,0)
  10256    S BEG=VPR START,END= VPRSTOP,LR ID=$G(VPRI D),ORPK=""
  10257   "RTN","VPR DJ0",58,0)
  10258    I $L(LRID ) D  ;rese t for LR7O R1
  10259   "RTN","VPR DJ0",59,0)
  10260    . I LRID  S ORPK=LRI D,LRID=$P( LRID,";",4 ,99) Q:LRI D=""  ;ord er
  10261   "RTN","VPR DJ0",60,0)
  10262    . S VPRSU B=$P(LRID, ";"),VPRID T=+$P(LRID ,";",2)
  10263   "RTN","VPR DJ0",61,0)
  10264    . S:VPRID T (BEG,END )=9999999- VPRIDT
  10265   "RTN","VPR DJ0",62,0)
  10266    S SUB=VPR SUB I $L(S UB),"CH^MI "'[SUB S S UB="AP"
  10267   "RTN","VPR DJ0",63,0)
  10268    D RR^LR7O R1(DFN,ORP K,BEG,END, SUB,,,VPRM AX)
  10269   "RTN","VPR DJ0",64,0)
  10270    S VPRSUB= "" F  S VP RSUB=$O(^T MP("LRRR", $J,DFN,VPR SUB)) Q:VP RSUB=""  D
  10271   "RTN","VPR DJ0",65,0)
  10272    . S VPRID T=0 F  S V PRIDT=$O(^ TMP("LRRR" ,$J,DFN,VP RSUB,VPRID T)) Q:VPRI DT<1  I $O (^(VPRIDT, 0)) D  Q:V PRI'<VPRMA X
  10273   "RTN","VPR DJ0",66,0)
  10274    .. I VPRS UB="MI"  S  ID=VPRSUB _";"_VPRID T D MI^VPR DJ06 Q
  10275   "RTN","VPR DJ0",67,0)
  10276    .. I VPRS UB'="CH" S  ID=VPRSUB _";"_VPRID T D AP^VPR DJ06 Q
  10277   "RTN","VPR DJ0",68,0)
  10278    .. D ACC^ VPRDJ06 ;g et chem ac cession da ta
  10279   "RTN","VPR DJ0",69,0)
  10280    .. S VPRP =0 F  S VP RP=$O(^TMP ("LRRR",$J ,DFN,VPRSU B,VPRIDT,V PRP)) Q:VP RP<1  S X= +$G(^(VPRP )) D
  10281   "RTN","VPR DJ0",70,0)
  10282    ... S VPR N=$$LRDN^L RPXAPIU(X)  I $L(LRID ,";")>2,VP RN'=$P(LRI D,";",3) Q
  10283   "RTN","VPR DJ0",71,0)
  10284    ... S ID= VPRSUB_";" _VPRIDT_"; "_VPRN D C H1^VPRDJ06
  10285   "RTN","VPR DJ0",72,0)
  10286    K ^TMP("L RRR",$J),^ TMP("LRX", $J)
  10287   "RTN","VPR DJ0",73,0)
  10288    Q
  10289   "RTN","VPR DJ0",74,0)
  10290    ;
  10291   "RTN","VPR DJ0",75,0)
  10292   PROCEDUR ;  -- Clinic al Procedu res
  10293   "RTN","VPR DJ0",76,0)
  10294    N VPRN,VP RX,BEG,END ,ID
  10295   "RTN","VPR DJ0",77,0)
  10296    S BEG=VPR START,END= VPRSTOP
  10297   "RTN","VPR DJ0",78,0)
  10298    I $G(VPRI D) D  ;res et dates f or VPRID o nly
  10299   "RTN","VPR DJ0",79,0)
  10300    . N VPRMC ,IEN,FILE, X
  10301   "RTN","VPR DJ0",80,0)
  10302    . S IEN=+ VPRID,FILE =+$P(VPRID ,"(",2)  Q :FILE=702   Q:'FILE
  10303   "RTN","VPR DJ0",81,0)
  10304    . D MEDLK UP^MCARUTL 3(.VPRMC,F ILE,IEN)
  10305   "RTN","VPR DJ0",82,0)
  10306    . S X=$P( VPRMC,U,6)  S:X (BEG, END)=X
  10307   "RTN","VPR DJ0",83,0)
  10308    D MDPS1^V PRDJ03(DFN ,BEG,END,V PRMAX)     ;gets ^TMP ("MDHSP",$ J)
  10309   "RTN","VPR DJ0",84,0)
  10310    S VPRN=0  F  S VPRN= $O(^TMP("M DHSP",$J,V PRN)) Q:VP RN<1  S VP RX=$G(^(VP RN)) D
  10311   "RTN","VPR DJ0",85,0)
  10312    . I $G(VP RID),+VPRI D'=+$P(VPR X,U,2) Q   ;update 1  procedure
  10313   "RTN","VPR DJ0",86,0)
  10314    . D MC1^V PRDJ03($G( VPRID))               ;uses VPRX
  10315   "RTN","VPR DJ0",87,0)
  10316    K ^TMP("M DHSP",$J)
  10317   "RTN","VPR DJ0",88,0)
  10318    Q
  10319   "RTN","VPR DJ0",89,0)
  10320    ;
  10321   "RTN","VPR DJ0",90,0)
  10322   OBS ; -- C linical Ob servations  (CLiO)
  10323   "RTN","VPR DJ0",91,0)
  10324    N VPRCLIO ,VPRN,ID,X
  10325   "RTN","VPR DJ0",92,0)
  10326    I $L($G(V PRID)) D M DC1^VPRDJ0 3(VPRID) Q
  10327   "RTN","VPR DJ0",93,0)
  10328    D QRYPT^V PRDMDC("VP RCLIO",DFN ,VPRSTART, VPRSTOP) ; all [verif ied] obser vations
  10329   "RTN","VPR DJ0",94,0)
  10330    S VPRN=0  F  S VPRN= $O(VPRCLIO (VPRN)) Q: (VPRN<1)!( VPRI'<VPRM AX)  D
  10331   "RTN","VPR DJ0",95,0)
  10332    . S ID=$G (VPRCLIO(V PRN)) ;GUI D
  10333   "RTN","VPR DJ0",96,0)
  10334    . D MDC1^ VPRDJ03(ID )
  10335   "RTN","VPR DJ0",97,0)
  10336    Q
  10337   "RTN","VPR DJ0",98,0)
  10338    ;
  10339   "RTN","VPR DJ0",99,0)
  10340   ORDER ; --  Order Ent ry
  10341   "RTN","VPR DJ0",100,0 )
  10342    N ORLIST, VPRN,DAD,I D,X,X3,X4
  10343   "RTN","VPR DJ0",101,0 )
  10344    I $G(VPRI D) S ORLIS T=$H D OR1 ^VPRDJ01(V PRID) G OR Q
  10345   "RTN","VPR DJ0",102,0 )
  10346    D EN^ORQ1 (DFN_";DPT (",,6,,VPR START,VPRS TOP,,,,1)
  10347   "RTN","VPR DJ0",103,0 )
  10348    S VPRN=0  F  S VPRN= $O(^TMP("O RR",$J,ORL IST,VPRN))  Q:VPRN<1   S ID=$G(^ (VPRN)) D   Q:VPRI'<V PRMAX
  10349   "RTN","VPR DJ0",104,0 )
  10350    . Q:$D(^T MP("ORGOTI T",$J,+ID) )  Q:$P(ID ,";",2)>1   S ID=+ID     ;action s
  10351   "RTN","VPR DJ0",105,0 )
  10352    . S X3=$G (^OR(100,I D,3)),X4=$ G(^(4))
  10353   "RTN","VPR DJ0",106,0 )
  10354    . Q:$P(X3 ,U,3)=13   I X4["P",$ P(X3,U,3)= 1!($P(X3,U ,3)=12) Q   ;cancelle d
  10355   "RTN","VPR DJ0",107,0 )
  10356    . S DAD=+ $P(X3,U,9)  I DAD D:' $D(^TMP("O RGOTIT",$J ,DAD)) OR1 ^VPRDJ01(D AD) Q
  10357   "RTN","VPR DJ0",108,0 )
  10358    . D OR1^V PRDJ01(ID)
  10359   "RTN","VPR DJ0",109,0 )
  10360   ORQ ; end
  10361   "RTN","VPR DJ0",110,0 )
  10362    K ^TMP("O RR",$J),^T MP("ORGOTI T",$J)
  10363   "RTN","VPR DJ0",111,0 )
  10364    Q
  10365   "RTN","VPR DJ0",112,0 )
  10366    ;
  10367   "RTN","VPR DJ0",113,0 )
  10368   TREATMEN ;  -- Nursin g Treatmen ts (orders )
  10369   "RTN","VPR DJ0",114,0 )
  10370    N ORLIST, ORDG,VPRN, ID,X,X3,X4
  10371   "RTN","VPR DJ0",115,0 )
  10372    I $G(VPRI D) S ORLIS T=$H D NTX 1^VPRDJ01( VPRID) G T XQ
  10373   "RTN","VPR DJ0",116,0 )
  10374    S ORDG=+$ O(^ORD(100 .98,"B","N TX",0))
  10375   "RTN","VPR DJ0",117,0 )
  10376    D EN^ORQ1 (DFN_";DPT (",ORDG,6, ,VPRSTART, VPRSTOP,,, ,1)
  10377   "RTN","VPR DJ0",118,0 )
  10378    S VPRN=0  F  S VPRN= $O(^TMP("O RR",$J,ORL IST,VPRN))  Q:VPRN<1   S ID=$G(^ (VPRN)) D   Q:VPRI'<V PRMAX
  10379   "RTN","VPR DJ0",119,0 )
  10380    . Q:$D(^T MP("ORGOTI T",$J,+ID) )  Q:$P(ID ,";",2)>1   S ID=+ID   ;actions
  10381   "RTN","VPR DJ0",120,0 )
  10382    . S X3=$G (^OR(100,I D,3)),X4=$ G(^(4))
  10383   "RTN","VPR DJ0",121,0 )
  10384    . Q:$P(X3 ,U,3)=13   I X4["P",$ P(X3,U,3)= 1!($P(X3,U ,3)=12) Q   ;cancelle d
  10385   "RTN","VPR DJ0",122,0 )
  10386    . D NTX1^ VPRDJ01(ID )
  10387   "RTN","VPR DJ0",123,0 )
  10388   TXQ ; end
  10389   "RTN","VPR DJ0",124,0 )
  10390    K ^TMP("O RR",$J),^T MP("ORGOTI T",$J)
  10391   "RTN","VPR DJ0",125,0 )
  10392    Q
  10393   "RTN","VPR DJ0",126,0 )
  10394    ;
  10395   "RTN","VPR DJ0",127,0 )
  10396   MED ; -- P harmacy
  10397   "RTN","VPR DJ0",128,0 )
  10398    N ORDIALO G I $G(VPR ID),$D(^OR (100,+VPRI D)) D PS1^ VPRDJ05(VP RID) Q        ;get 1  order
  10399   "RTN","VPR DJ0",129,0 )
  10400    N TYPE,OR DG,ORVP,OR LIST,VPRN, ORLIST,X3, X4,DAD,ID
  10401   "RTN","VPR DJ0",130,0 )
  10402    S TYPE=$G (FILTER("v aType")) S :$L(TYPE)  TYPE=$S(TY PE="N":"NV ",TYPE="V" :"IV",1:TY PE)_" "
  10403   "RTN","VPR DJ0",131,0 )
  10404    S ORDG=+$ O(^ORD(100 .98,"B",TY PE_"RX",0) ),ORVP=DFN _";DPT("
  10405   "RTN","VPR DJ0",132,0 )
  10406    D EN^ORQ1 (ORVP,ORDG ,6,,VPRSTA RT,VPRSTOP )
  10407   "RTN","VPR DJ0",133,0 )
  10408    K ^TMP("V PROR",$J)  S VPRN=0
  10409   "RTN","VPR DJ0",134,0 )
  10410    F  S VPRN =$O(^TMP(" ORR",$J,OR LIST,VPRN) ) Q:VPRN<1   S ID=$G( ^(VPRN)) D   Q:VPRI'< VPRMAX
  10411   "RTN","VPR DJ0",135,0 )
  10412    . Q:$D(^T MP("VPROR" ,$J,+ID))   Q:$P(ID," ;",2)>1  S  ID=+ID
  10413   "RTN","VPR DJ0",136,0 )
  10414    . S X3=$G (^OR(100,I D,3)),X4=$ G(^(4))
  10415   "RTN","VPR DJ0",137,0 )
  10416    . Q:$P(X3 ,U,3)=13   I X4["P",$ P(X3,U,3)= 1!($P(X3,U ,3)=12) Q   ;cancelle d
  10417   "RTN","VPR DJ0",138,0 )
  10418    . S DAD=$ P(X3,U,9)  I DAD Q:$D (^TMP("VPR OR",$J,DAD ))  S ID=D AD
  10419   "RTN","VPR DJ0",139,0 )
  10420    . D PS1^V PRDJ05(ID)  S ^TMP("V PROR",$J,I D)=""
  10421   "RTN","VPR DJ0",140,0 )
  10422    K ^TMP("V PROR",$J), ^TMP("ORR" ,$J),^TMP( "ORGOTIT", $J),^TMP($ J,"PSOI")
  10423   "RTN","VPR DJ0",141,0 )
  10424    Q
  10425   "RTN","VPR DJ0",142,0 )
  10426    ;
  10427   "RTN","VPR DJ0",143,0 )
  10428   PTF ; -- P atient Tre atment Fil e
  10429   "RTN","VPR DJ0",144,0 )
  10430    N VPRIDT, ID,P,TYPE
  10431   "RTN","VPR DJ0",145,0 )
  10432    I $G(VPRI D),VPRID'= +VPRID D P TFA^VPRDJ0 4A(VPRID)  Q
  10433   "RTN","VPR DJ0",146,0 )
  10434    I $G(VPRI D) D  Q:'$ D(^TMP("VP RPX",$J))   ;update v ia DGPM =  ien only
  10435   "RTN","VPR DJ0",147,0 )
  10436    . N X,Y,I  S VPRIDT= 9999999                ;so build  ^TMP node s
  10437   "RTN","VPR DJ0",148,0 )
  10438    . D RPC^D GPTFAPI(.Y ,VPRID)
  10439   "RTN","VPR DJ0",149,0 )
  10440    . S X=$P( $G(Y(1)),U ,3) I $L(X ) S ^TMP(" VPRPX",$J, VPRIDT,VPR ID_";70;DX LS")=X_U
  10441   "RTN","VPR DJ0",150,0 )
  10442    . F I=1:1 :9 S X=$P( $G(Y(2)),U ,I) I $L(X ) S ^TMP(" VPRPX",$J, VPRIDT,VPR ID_";70;D  SD"_I)=X_U
  10443   "RTN","VPR DJ0",151,0 )
  10444    D:'$G(VPR ID) PTF^VP RDJ09 ;sor t ^PXRMIND X into ^TM P("VPRPX", $J,IDT)
  10445   "RTN","VPR DJ0",152,0 )
  10446    S VPRIDT= 0 F  S VPR IDT=$O(^TM P("VPRPX", $J,VPRIDT) ) Q:VPRIDT <1  D  Q:V PRI'<VPRMA X
  10447   "RTN","VPR DJ0",153,0 )
  10448    . S ID=""  F  S ID=$ O(^TMP("VP RPX",$J,VP RIDT,ID))  Q:ID=""  D  PTF1^VPRD J04A Q:VPR I'<VPRMAX
  10449   "RTN","VPR DJ0",154,0 )
  10450    K ^TMP("V PRPX",$J)
  10451   "RTN","VPR DJ0",155,0 )
  10452    Q
  10453   "RTN","VPR DJ0",156,0 )
  10454    ;
  10455   "RTN","VPR DJ0",157,0 )
  10456   FACTOR   D  PX^VPRDJ0 9(9000010. 23) Q   ;  -- PCE Hea lth Factor s
  10457   "RTN","VPR DJ0",158,0 )
  10458   IMMUNIZA D  PX^VPRDJ0 9(9000010. 11) Q   ;  -- PCE Imm unizations
  10459   "RTN","VPR DJ0",159,0 )
  10460   EXAM     D  PX^VPRDJ0 9(9000010. 13) Q   ;  -- PCE Exa ms
  10461   "RTN","VPR DJ0",160,0 )
  10462   CPT      D  PX^VPRDJ0 9(9000010. 18) Q   ;  -- PCE CPT
  10463   "RTN","VPR DJ0",161,0 )
  10464   EDUCATIO D  PX^VPRDJ0 9(9000010. 16) Q   ;  -- PCE Pat ient Educa tion
  10465   "RTN","VPR DJ0",162,0 )
  10466   POV      D  PX^VPRDJ0 9(9000010. 07) Q   ;  -- PCE Pur pose of Vi sit (POV)
  10467   "RTN","VPR DJ0",163,0 )
  10468   SKIN     D  PX^VPRDJ0 9(9000010. 12) Q   ;  -- PCE Ski n Tests
  10469   "RTN","VPR DJ0",164,0 )
  10470    ;
  10471   "RTN","VPR DJ0",165,0 )
  10472   IMAGE ; --  Radiology /Nuclear M edicine
  10473   "RTN","VPR DJ0",166,0 )
  10474    D EN1^RAO 7PC1(DFN,V PRSTART,VP RSTOP,VPRM AX_"P")
  10475   "RTN","VPR DJ0",167,0 )
  10476    I $G(VPRI D) D RA1^V PRDJ07(VPR ID) G IMQ
  10477   "RTN","VPR DJ0",168,0 )
  10478    N ID S ID =""
  10479   "RTN","VPR DJ0",169,0 )
  10480    F  S ID=$ O(^TMP($J, "RAE1",DFN ,ID)) Q:ID =""  D RA1 ^VPRDJ07(I D)  Q:VPRI '<+VPRMAX
  10481   "RTN","VPR DJ0",170,0 )
  10482   IMQ ; end
  10483   "RTN","VPR DJ0",171,0 )
  10484    K ^TMP($J ,"RAE1")
  10485   "RTN","VPR DJ0",172,0 )
  10486    Q
  10487   "RTN","VPR DJ0",173,0 )
  10488    ;
  10489   "RTN","VPR DJ0",174,0 )
  10490   APPOINTM ;  -- Schedu ling/Appoi ntment Mgt
  10491   "RTN","VPR DJ0",175,0 )
  10492    N VPRX,VP RNUM,VPRDT ,X,VPRA,ID
  10493   "RTN","VPR DJ0",176,0 )
  10494    S VPRX(1) =VPRSTART_ ";"_VPRSTO P,VPRX(4)= DFN,ID=$G( VPRID)
  10495   "RTN","VPR DJ0",177,0 )
  10496    S VPRX("F LDS")="1;2 ;3;6;9;10; 11;13",VPR X("SORT")= "P"
  10497   "RTN","VPR DJ0",178,0 )
  10498    I $L(ID)  G:$E(ID)=" H" DGS^VPR DJ04 D  Q
  10499   "RTN","VPR DJ0",179,0 )
  10500    . S VPRDT =$P(ID,";" ,2),VPRX(1 )=$P(ID,"; ",2)_";"_$ P(ID,";",2 )
  10501   "RTN","VPR DJ0",180,0 )
  10502    . S VPRX( 2)=$P(ID," ;",3)
  10503   "RTN","VPR DJ0",181,0 )
  10504    . S VPRNU M=$$SDAPI^ SDAMA301(. VPRX)
  10505   "RTN","VPR DJ0",182,0 )
  10506    . D:VPRNU M>0 SDAM1^ VPRDJ04
  10507   "RTN","VPR DJ0",183,0 )
  10508    . K ^TMP( $J,"SDAMA3 01",DFN)
  10509   "RTN","VPR DJ0",184,0 )
  10510    ; appoint ments
  10511   "RTN","VPR DJ0",185,0 )
  10512    S VPRX(3) ="R;I;NS;N SR;NT" ;no  cancelled  appt's
  10513   "RTN","VPR DJ0",186,0 )
  10514    S VPRNUM= $$SDAPI^SD AMA301(.VP RX),VPRDT= 0
  10515   "RTN","VPR DJ0",187,0 )
  10516    F  S VPRD T=$O(^TMP( $J,"SDAMA3 01",DFN,VP RDT)) Q:VP RDT<1  D   Q:VPRI'<VP RMAX
  10517   "RTN","VPR DJ0",188,0 )
  10518    . S X=$P( $G(^TMP($J ,"SDAMA301 ",DFN,VPRD T)),U,3)
  10519   "RTN","VPR DJ0",189,0 )
  10520    . ;I VPRD T<DT,$P(X, ";")'["NS"  Q   ;no p rior kept  appt's
  10521   "RTN","VPR DJ0",190,0 )
  10522    . D SDAM1 ^VPRDJ04
  10523   "RTN","VPR DJ0",191,0 )
  10524    K ^TMP($J ,"SDAMA301 ",DFN)
  10525   "RTN","VPR DJ0",192,0 )
  10526    Q
  10527   "RTN","VPR DJ0",193,0 )
  10528    ;
  10529   "RTN","VPR DJ0",194,0 )
  10530   SURGERY ;  -- Surgery
  10531   "RTN","VPR DJ0",195,0 )
  10532    I $G(VPRI D) D SR1^V PRDJ07(VPR ID) Q
  10533   "RTN","VPR DJ0",196,0 )
  10534    Q:'$L($T( LIST^SROES TV))
  10535   "RTN","VPR DJ0",197,0 )
  10536    N SHOWADD  S SHOWADD =1 ;to omi t leading  '+' with n ote titles
  10537   "RTN","VPR DJ0",198,0 )
  10538    N VPRN,VP RY,ID D LI ST^SROESTV (.VPRY,DFN ,VPRSTART, VPRSTOP,VP RMAX,1)
  10539   "RTN","VPR DJ0",199,0 )
  10540    S VPRN=0  F  S VPRN= $O(@VPRY@( VPRN)) Q:V PRN<1  D
  10541   "RTN","VPR DJ0",200,0 )
  10542    . S ID=+$ G(@VPRY@(V PRN)) D:ID  SR1^VPRDJ 07(ID)
  10543   "RTN","VPR DJ0",201,0 )
  10544    K @VPRY
  10545   "RTN","VPR DJ0",202,0 )
  10546    Q
  10547   "RTN","VPR DJ0",203,0 )
  10548    ;
  10549   "RTN","VPR DJ0",204,0 )
  10550   DOCUMENT ;  -- Text I ntegration  Utilities
  10551   "RTN","VPR DJ0",205,0 )
  10552    N VPRC,CL S,VPRS,CTX T,VPRY,VPR N,VPRX,ID
  10553   "RTN","VPR DJ0",206,0 )
  10554    I $L($G(V PRID)) D T IU1^VPRDJ0 8(VPRID) Q
  10555   "RTN","VPR DJ0",207,0 )
  10556    N CLASS,S UBCLASS,ST ATUS
  10557   "RTN","VPR DJ0",208,0 )
  10558    D SETUP^V PRDJ08 ;de fine searc h criteria
  10559   "RTN","VPR DJ0",209,0 )
  10560    F VPRC=1: 1:$L(CLASS ,U) S CLS= $P(CLASS,U ,VPRC) D   Q:VPRI'<VP RMAX
  10561   "RTN","VPR DJ0",210,0 )
  10562    . I CLS=" CP" D CP^V PRDJ08A(DF N,VPRSTART ,VPRSTOP,V PRMAX) Q
  10563   "RTN","VPR DJ0",211,0 )
  10564    . I CLS=" RA" D RA^V PRDJ08A(DF N,VPRSTART ,VPRSTOP,V PRMAX) Q
  10565   "RTN","VPR DJ0",212,0 )
  10566    . I CLS=" LR" D LR^V PRDJ08A(DF N,VPRSTART ,VPRSTOP,V PRMAX) Q
  10567   "RTN","VPR DJ0",213,0 )
  10568    . ; TIU d ocument cl asses, by  sig status
  10569   "RTN","VPR DJ0",214,0 )
  10570    . F VPRS= 1:1:$L(STA TUS,U) S C TXT=$P(STA TUS,U,VPRS ) D  Q:VPR I'<VPRMAX
  10571   "RTN","VPR DJ0",215,0 )
  10572    .. I $L($ T(GET^TIUV PR)) D GET ^TIUVPR(.V PRY,DFN,CL S,VPRSTART ,VPRSTOP)  I 1
  10573   "RTN","VPR DJ0",216,0 )
  10574    .. E  D C ONTEXT^TIU SRVLO(.VPR Y,CLS,CTXT ,DFN,VPRST ART,VPRSTO P,,VPRMAX, ,1)
  10575   "RTN","VPR DJ0",217,0 )
  10576    .. S VPRN =0 F  S VP RN=$O(@VPR Y@(VPRN))  Q:VPRN<1   D  Q:VPRI' <VPRMAX
  10577   "RTN","VPR DJ0",218,0 )
  10578    ... S VPR X=$G(@VPRY @(VPRN)) ; Q:'$$MATCH ^VPRDJ08(V PRX,CTXT)
  10579   "RTN","VPR DJ0",219,0 )
  10580    ... Q:$D( ^TMP("VPRD ",$J,+VPRX ))  ;alrea dy include d
  10581   "RTN","VPR DJ0",220,0 )
  10582    ... D EN1 ^VPRDJ08(V PRX,CLS)
  10583   "RTN","VPR DJ0",221,0 )
  10584    .. K @VPR Y
  10585   "RTN","VPR DJ0",222,0 )
  10586    Q
  10587   "RTN","VPR DJ0",223,0 )
  10588    ;
  10589   "RTN","VPR DJ0",224,0 )
  10590   VISIT ; --  Visits
  10591   "RTN","VPR DJ0",225,0 )
  10592    I $L($G(V PRID)) D V SIT1^VPRDJ 04(VPRID)  Q
  10593   "RTN","VPR DJ0",226,0 )
  10594    N VPRIDT, BEG,END,ID
  10595   "RTN","VPR DJ0",227,0 )
  10596    N VPRADMI T S VPRADM IT=+$G(^DP T(DFN,.105 )) ;curren t admissio n
  10597   "RTN","VPR DJ0",228,0 )
  10598    S BEG=VPR START,END= VPRSTOP D  IDT^VPRDVS IT ;invert  dates
  10599   "RTN","VPR DJ0",229,0 )
  10600    S VPRIDT= BEG F  S V PRIDT=$O(^ AUPNVSIT(" AA",DFN,VP RIDT)) Q:V PRIDT<1!(V PRIDT>END)   D  Q:VPR I'<VPRMAX
  10601   "RTN","VPR DJ0",230,0 )
  10602    . S ID=0  F  S ID=$O (^AUPNVSIT ("AA",DFN, VPRIDT,ID) ) Q:ID<1   D VSIT1^VP RDJ04(ID)
  10603   "RTN","VPR DJ0",231,0 )
  10604    ; kill VP RADMIT in  VSIT1 if a dm is incl uded, but  add unless  filtered
  10605   "RTN","VPR DJ0",232,0 )
  10606    I $G(VPRA DMIT),VPRM AX'<9999,V PRSTART'>1 410102 D V SIT1^VPRDJ 04("H"_VPR ADMIT)
  10607   "RTN","VPR DJ0",233,0 )
  10608    Q
  10609   "RTN","VPR DJ0",234,0 )
  10610    ;I VPRSTO P,VPRSTOP' ["." S END =VPRSTOP_" .24" ;assu me end of  day
  10611   "RTN","VPR DJ0",235,0 )
  10612    ;S VPRDT= END F  S V PRDT=$O(^A UPNVSIT("A ET",DFN,VP RDT),-1)   Q:VPRDT<VP RSTART  D   Q:VPRI'<V PRMAX
  10613   "RTN","VPR DJ0",236,0 )
  10614    ;. S VPRL OC=0 F  S  VPRLOC=$O( ^AUPNVSIT( "AET",DFN, VPRDT,VPRL OC)) Q:VPR LOC<1  D
  10615   "RTN","VPR DJ0",237,0 )
  10616    ;.. S ID= 0 F  S ID= $O(^AUPNVS IT("AET",D FN,VPRDT,V PRLOC,"P", ID)) Q:ID< 1  D VSIT1 ^VPRDJ04(I D)
  10617   "RTN","VPR DJ0",238,0 )
  10618    ;
  10619   "RTN","VPR DJ0",239,0 )
  10620   VPR ; -- V PR Patient  Objects
  10621   "RTN","VPR DJ0",240,0 )
  10622    D VPR^VPR DJ02($G(TY PE))
  10623   "RTN","VPR DJ0",241,0 )
  10624    Q
  10625   "RTN","VPR DJ0",242,0 )
  10626    ;
  10627   "RTN","VPR DJ0",243,0 )
  10628   MH ; -- Me ntal Healt h
  10629   "RTN","VPR DJ0",244,0 )
  10630    I $L($T(M H^VPRDJ09M )) D MH^VP RDJ09M
  10631   "RTN","VPR DJ0",245,0 )
  10632    Q
  10633   "RTN","VPR DJ0",246,0 )
  10634    ;
  10635   "RTN","VPR DJ0",247,0 )
  10636   ERRQ ; --  Quit for e rror handl ing
  10637   "RTN","VPR DJ0",248,0 )
  10638    Q
  10639   "RTN","VPR DJ00")
  10640   0^70^B8219 1194
  10641   "RTN","VPR DJ00",1,0)
  10642   VPRDJ00 ;S LC/MKB --  Patient de mographics  ;8/11/11   15:29
  10643   "RTN","VPR DJ00",2,0)
  10644    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  10645   "RTN","VPR DJ00",3,0)
  10646    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  10647   "RTN","VPR DJ00",4,0)
  10648    ;
  10649   "RTN","VPR DJ00",5,0)
  10650    ; Externa l Referenc es           DBIA#
  10651   "RTN","VPR DJ00",6,0)
  10652    ; ------- ---------- --           -----
  10653   "RTN","VPR DJ00",7,0)
  10654    ; ^AUPNVS IT                       2028
  10655   "RTN","VPR DJ00",8,0)
  10656    ; ^DPT                            10035
  10657   "RTN","VPR DJ00",9,0)
  10658    ; DGCV                             4156
  10659   "RTN","VPR DJ00",10,0 )
  10660    ; DGMSTAP I                        2716
  10661   "RTN","VPR DJ00",11,0 )
  10662    ; DGNTAPI                          3457
  10663   "RTN","VPR DJ00",12,0 )
  10664    ; DGPFAPI                          3860
  10665   "RTN","VPR DJ00",13,0 )
  10666    ; DGRPDB                           4807
  10667   "RTN","VPR DJ00",14,0 )
  10668    ; DIQ                              2056
  10669   "RTN","VPR DJ00",15,0 )
  10670    ; MPIF001                          2701
  10671   "RTN","VPR DJ00",16,0 )
  10672    ; SDUTL3                           1252
  10673   "RTN","VPR DJ00",17,0 )
  10674    ; VADPT                           10061
  10675   "RTN","VPR DJ00",18,0 )
  10676    ; VAFCTFU 1                        2990
  10677   "RTN","VPR DJ00",19,0 )
  10678    ; VASITE                          10112
  10679   "RTN","VPR DJ00",20,0 )
  10680    ; XUAF4                            2171
  10681   "RTN","VPR DJ00",21,0 )
  10682    ;
  10683   "RTN","VPR DJ00",22,0 )
  10684    ; All tag s expect D FN, VPRID,  [VPRSTART , VPRSTOP,  VPRMAX, V PRTEXT]
  10685   "RTN","VPR DJ00",23,0 )
  10686    ;
  10687   "RTN","VPR DJ00",24,0 )
  10688   DPT1OD(PAT ) ;
  10689   "RTN","VPR DJ00",25,0 )
  10690    N SYS S S YS=$$SITE^ VASITE
  10691   "RTN","VPR DJ00",26,0 )
  10692    N $ES,$ET ,ERRPAT,ER RMSG
  10693   "RTN","VPR DJ00",27,0 )
  10694    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  10695   "RTN","VPR DJ00",28,0 )
  10696    S ERRMSG= "A problem  occurred  building t he patient  "_DFN_" d emographic  extract."
  10697   "RTN","VPR DJ00",29,0 )
  10698    D DEM,SVC ,PRF,ATC,S UPP,ALIAS, FAC,PC
  10699   "RTN","VPR DJ00",30,0 )
  10700    Q
  10701   "RTN","VPR DJ00",31,0 )
  10702    ;
  10703   "RTN","VPR DJ00",32,0 )
  10704   DPT1 ; --  Demographi cs [VPRSTA RT,VPRSTOP ,VPRMAX,VP RID not cu rrently us ed here]
  10705   "RTN","VPR DJ00",33,0 )
  10706    N PAT,SYS  S SYS=$$S ITE^VASITE
  10707   "RTN","VPR DJ00",34,0 )
  10708    N $ES,$ET ,ERRPAT,ER RMSG
  10709   "RTN","VPR DJ00",35,0 )
  10710    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  10711   "RTN","VPR DJ00",36,0 )
  10712    S ERRMSG= "A problem  occurred  building t he patient  "_DFN_" d emographic  extract."
  10713   "RTN","VPR DJ00",37,0 )
  10714    D DEM,SVC ,PRF,ATC,S UPP,ALIAS, FAC,PC
  10715   "RTN","VPR DJ00",38,0 )
  10716    I $D(PAT) >9 D ADD^V PRDJ("PAT" )
  10717   "RTN","VPR DJ00",39,0 )
  10718    Q
  10719   "RTN","VPR DJ00",40,0 )
  10720    ;
  10721   "RTN","VPR DJ00",41,0 )
  10722   LKUP ; pat ient looku p data
  10723   "RTN","VPR DJ00",42,0 )
  10724    ; expects  VPRSYS,DF N
  10725   "RTN","VPR DJ00",43,0 )
  10726    N X,X0
  10727   "RTN","VPR DJ00",44,0 )
  10728    S X0=^DPT (DFN,0),X= $P(X0,U)
  10729   "RTN","VPR DJ00",45,0 )
  10730    S PAT("fu llName")=X
  10731   "RTN","VPR DJ00",46,0 )
  10732    S PAT("fa milyName") =$P(X,",")
  10733   "RTN","VPR DJ00",47,0 )
  10734    S PAT("gi venNames") =$P(X,",", 2,99)
  10735   "RTN","VPR DJ00",48,0 )
  10736    S X=$P(X0 ,U,2)
  10737   "RTN","VPR DJ00",49,0 )
  10738    S PAT("ge nderCode") ="urn:va:p at-gender: "_X
  10739   "RTN","VPR DJ00",50,0 )
  10740    S PAT("ge nderName") =$$NAME(X, "gender")
  10741   "RTN","VPR DJ00",51,0 )
  10742    S PAT("lo calId")=DF N
  10743   "RTN","VPR DJ00",52,0 )
  10744    S PAT("pi d")=VPRSYS _";"_DFN
  10745   "RTN","VPR DJ00",53,0 )
  10746    S PAT("ui d")=$$SETU ID^VPRUTIL S("pt-sele ct",DFN,DF N)
  10747   "RTN","VPR DJ00",54,0 )
  10748    S X=$$GET ICN^MPIF00 1(DFN)
  10749   "RTN","VPR DJ00",55,0 )
  10750    S:X>0 PAT ("icn")=X
  10751   "RTN","VPR DJ00",56,0 )
  10752    S PAT("ss n")=$P(X0, U,9)
  10753   "RTN","VPR DJ00",57,0 )
  10754    S PAT("da teOfBirth" )=$$JSONDT ^VPRUTILS( $P(X0,U,3) )
  10755   "RTN","VPR DJ00",58,0 )
  10756    S PAT("se nsitive")= $$BOOL($$S CREEN^DPTL K1(DFN))
  10757   "RTN","VPR DJ00",59,0 )
  10758    S X=$P($G (^DPT(DFN, .35)),U)
  10759   "RTN","VPR DJ00",60,0 )
  10760    S:X PAT(" died")=$$J SONDT^VPRU TILS(X)
  10761   "RTN","VPR DJ00",61,0 )
  10762    I $D(PAT) >9 D ADD^V PRDJ("PAT" )
  10763   "RTN","VPR DJ00",62,0 )
  10764    Q
  10765   "RTN","VPR DJ00",63,0 )
  10766   DEM ;-demo graphic da ta
  10767   "RTN","VPR DJ00",64,0 )
  10768    N VADM,VA ,VAERR,X
  10769   "RTN","VPR DJ00",65,0 )
  10770    S X=$$GET ICN^MPIF00 1(DFN) S:X >1 PAT("ic n")=X
  10771   "RTN","VPR DJ00",66,0 )
  10772    D DEM^VAD PT S X=VAD M(1),PAT(" fullName") =X
  10773   "RTN","VPR DJ00",67,0 )
  10774    S PAT("fa milyName") =$P(X,",") ,PAT("give nNames")=$ P(X,",",2, 99)
  10775   "RTN","VPR DJ00",68,0 )
  10776    S PAT("ss n")=$P(VAD M(2),U),PA T("localId ")=DFN
  10777   "RTN","VPR DJ00",69,0 )
  10778    S PAT("ui d")=$$SETU ID^VPRUTIL S("patient ",DFN,DFN)
  10779   "RTN","VPR DJ00",70,0 )
  10780    S:$D(VA(" BID")) PAT ("briefId" )=$E(X)_VA ("BID")
  10781   "RTN","VPR DJ00",71,0 )
  10782    S X=+$P($ P(VADM(3), U),"."),PA T("dateOfB irth")=$$J SONDT^VPRU TILS(X)
  10783   "RTN","VPR DJ00",72,0 )
  10784    S X=$P(VA DM(5),U),P AT("gender Code")="ur n:va:pat-g ender:"_X, PAT("gende rName")=$$ NAME(X,"ge nder")
  10785   "RTN","VPR DJ00",73,0 )
  10786    S X=+$P($ P(VADM(6), U),".") S: X PAT("die d")=$$JSON DT^VPRUTIL S(X)
  10787   "RTN","VPR DJ00",74,0 )
  10788    S X=$$GET 1^DIQ(38.1 ,DFN_",",2 ,"I") S:$L (X) PAT("s ensitive") =$$BOOL(X)
  10789   "RTN","VPR DJ00",75,0 )
  10790    S X=+VADM (9) S:X PA T("religio nCode")="u rn:va:pat- religion:" _X,PAT("re ligionName ")=$$NAME( X,"religio n")
  10791   "RTN","VPR DJ00",76,0 )
  10792    S X=$P(VA DM(10),U,2 ) I $L(X)  D  ;PAT("m aritalStat us")=$E(X)
  10793   "RTN","VPR DJ00",77,0 )
  10794    . S X=$E( X),X=$S(X= "S":"L",X= "N":"S",1: X)
  10795   "RTN","VPR DJ00",78,0 )
  10796    . S PAT(" maritalSta tuses",1," code")="ur n:va:pat-m aritalStat us:"_X
  10797   "RTN","VPR DJ00",79,0 )
  10798    . S PAT(" maritalSta tuses",1," name")=$$N AME(X,"mar italStatus ")
  10799   "RTN","VPR DJ00",80,0 )
  10800    I VADM(11 ) D
  10801   "RTN","VPR DJ00",81,0 )
  10802    . N I S I =0
  10803   "RTN","VPR DJ00",82,0 )
  10804    . F  S I= $O(VADM(11 ,I)) Q:I<1   S X=+VAD M(11,I),PA T("ethnici ties",X,"e thnicity") =$$GET1^DI Q(2.06,X_" ,"_DFN_"," ,".01:3")
  10805   "RTN","VPR DJ00",83,0 )
  10806    I VADM(12 ) D
  10807   "RTN","VPR DJ00",84,0 )
  10808    . N I S I =0
  10809   "RTN","VPR DJ00",85,0 )
  10810    . F  S I= $O(VADM(12 ,I)) Q:I<1   S X=+VAD M(12,I),PA T("races", X,"race")= $$GET1^DIQ (2.02,X_", "_DFN_",", ".01:3")
  10811   "RTN","VPR DJ00",86,0 )
  10812    Q
  10813   "RTN","VPR DJ00",87,0 )
  10814   SVC ;-serv ice data
  10815   "RTN","VPR DJ00",88,0 )
  10816    N VAEL,VA SV,VAERR,X ,Y,I,P,AO, IR,PGF,HNC ,MST,CV,VP RSC
  10817   "RTN","VPR DJ00",89,0 )
  10818    D 7^VADPT
  10819   "RTN","VPR DJ00",90,0 )
  10820    ; PAT("ve teran")=VA EL(4)
  10821   "RTN","VPR DJ00",91,0 )
  10822    S PAT("ve teran","se rviceConne cted")=$$B OOL(+VAEL( 3)) I VAEL (3) D
  10823   "RTN","VPR DJ00",92,0 )
  10824    . S PAT(" veteran"," serviceCon nectionPer cent")=+$P (VAEL(3),U ,2)
  10825   "RTN","VPR DJ00",93,0 )
  10826    . D GETS^ DIQ(2,DFN_ ",",".3731 *",,"VPRSC ")
  10827   "RTN","VPR DJ00",94,0 )
  10828    . S I=""  F  S I=$O( VPRSC(2.05 ,I)) Q:I=" "  D
  10829   "RTN","VPR DJ00",95,0 )
  10830    .. S PAT( "veteran", "scConditi ons",+I,"n ame")=VPRS C(2.05,I,. 01)
  10831   "RTN","VPR DJ00",96,0 )
  10832    .. S PAT( "veteran", "scConditi ons",+I,"s cPercent") =VPRSC(2.0 5,I,.02)
  10833   "RTN","VPR DJ00",97,0 )
  10834    S X=+$G(^ DPT(DFN,"L R")) S:X P AT("vetera n","lrdfn" )=X
  10835   "RTN","VPR DJ00",98,0 )
  10836    ;
  10837   "RTN","VPR DJ00",99,0 )
  10838    ; exposur es
  10839   "RTN","VPR DJ00",100, 0)
  10840    S AO=VASV (2),IR=VAS V(3)
  10841   "RTN","VPR DJ00",101, 0)
  10842    S PGF=VAS V(11)!VASV (12)!VASV( 13) ;OIF/O EF
  10843   "RTN","VPR DJ00",102, 0)
  10844    S X=$$GET CUR^DGNTAP I(DFN,"HNC "),X=+($G( HNC("STAT" )))
  10845   "RTN","VPR DJ00",103, 0)
  10846    S HNC=$S( X=4:1,X=5: 1,X=1:0,X= 6:0,1:"")
  10847   "RTN","VPR DJ00",104, 0)
  10848    S X=$P($$ GETSTAT^DG MSTAPI(DFN ),U,2),MST =$S(X="Y": 1,X="N":0, 1:"")
  10849   "RTN","VPR DJ00",105, 0)
  10850    S X=$$CVE DT^DGCV(DF N),CV=$S(+ X<0:"",+X= 0:0,$P(X,U ,3):1,1:0)
  10851   "RTN","VPR DJ00",106, 0)
  10852    S X=AO_U_ IR_U_PGF_U _HNC_U_MST _U_CV
  10853   "RTN","VPR DJ00",107, 0)
  10854    F P=1:1:6  S I=$P(X, U,P),$P(X, U,P)=$S(I: "Yes",I=0: "No",1:"Un known")
  10855   "RTN","VPR DJ00",108, 0)
  10856    S NM="age nt-orange^ ionizing-r adiation^s w-asia^hea d-neck-can cer^mst^co mbat-vet"
  10857   "RTN","VPR DJ00",109, 0)
  10858    F P=1:1:6  S PAT("ex posures",P ,"uid")="u rn:va:"_$P (NM,U,P)_" :"_$E($P(X ,U,P)),PAT ("exposure s",P,"name ")=$P(X,U, P)
  10859   "RTN","VPR DJ00",110, 0)
  10860    ;
  10861   "RTN","VPR DJ00",111, 0)
  10862    ; rated d isabilitie s [DGRPDB]
  10863   "RTN","VPR DJ00",112, 0)
  10864    N VPRDIS, DIS,NM,DX
  10865   "RTN","VPR DJ00",113, 0)
  10866    D RDIS^DG RPDB(DFN,. VPRDIS)
  10867   "RTN","VPR DJ00",114, 0)
  10868    S I=0 F   S I=$O(VPR DIS(I)) Q: I<1  D
  10869   "RTN","VPR DJ00",115, 0)
  10870    . S DIS=V PRDIS(I)
  10871   "RTN","VPR DJ00",116, 0)
  10872    . S NM=$$ GET1^DIQ(3 1,+DIS_"," ,.01),DX=$ $GET1^DIQ( 31,+DIS_", ",2)
  10873   "RTN","VPR DJ00",117, 0)
  10874    . S PAT(" disabiliti es",+DX,"n ame")=NM
  10875   "RTN","VPR DJ00",118, 0)
  10876    . S PAT(" disabiliti es",+DX,"d isPercent" )=$P(DIS,U ,2)
  10877   "RTN","VPR DJ00",119, 0)
  10878    . S PAT(" disabiliti es",+DX,"s erviceConn ected")=$$ BOOL($P(DI S,U,3))
  10879   "RTN","VPR DJ00",120, 0)
  10880    Q
  10881   "RTN","VPR DJ00",121, 0)
  10882   PRF ;-pati ent record  flags
  10883   "RTN","VPR DJ00",122, 0)
  10884    N VPRPF,I ,NAME,TEXT
  10885   "RTN","VPR DJ00",123, 0)
  10886    Q:'$$GETA CT^DGPFAPI (DFN,"VPRP F")
  10887   "RTN","VPR DJ00",124, 0)
  10888    S I=0 F   S I=$O(VPR PF(I)) Q:I <1  D
  10889   "RTN","VPR DJ00",125, 0)
  10890    . S NAME= $P(VPRPF(I ,"FLAG"),U ,2)
  10891   "RTN","VPR DJ00",126, 0)
  10892    . M TEXT= VPRPF(I,"N ARR")
  10893   "RTN","VPR DJ00",127, 0)
  10894    . S PAT(" flags",I," name")=NAM E
  10895   "RTN","VPR DJ00",128, 0)
  10896    . S PAT(" flags",I," text")=$$S TRING^VPRD (.TEXT)
  10897   "RTN","VPR DJ00",129, 0)
  10898    Q
  10899   "RTN","VPR DJ00",130, 0)
  10900   ATC ;-addr ess & tele com
  10901   "RTN","VPR DJ00",131, 0)
  10902    N VAPA,I, X,P,NM
  10903   "RTN","VPR DJ00",132, 0)
  10904    S VAPA("P ")="" D AD D^VADPT ;p ermanent a ddress
  10905   "RTN","VPR DJ00",133, 0)
  10906    S:$L(VAPA (1)) PAT(" addresses" ,1,"street Line1")=VA PA(1)
  10907   "RTN","VPR DJ00",134, 0)
  10908    S X=VAPA( 2) I $L(X) ,$L(VAPA(3 )) S X=X_"  "_VAPA(3)
  10909   "RTN","VPR DJ00",135, 0)
  10910    S:$L(X) P AT("addres ses",1,"st reetLine2" )=X
  10911   "RTN","VPR DJ00",136, 0)
  10912    S:$L(VAPA (4)) PAT(" addresses" ,1,"city") =VAPA(4)
  10913   "RTN","VPR DJ00",137, 0)
  10914    S X=$P(VA PA(5),U,2)  S:$L(X) P AT("addres ses",1,"st ateProvinc e")=X
  10915   "RTN","VPR DJ00",138, 0)
  10916    S X=$P(VA PA(11),U,2 ) S:$L(X)  PAT("addre sses",1,"p ostalCode" )=X
  10917   "RTN","VPR DJ00",139, 0)
  10918    ; 
  10919   "RTN","VPR DJ00",140, 0)
  10920    ; X=home^ cell^work  phones
  10921   "RTN","VPR DJ00",141, 0)
  10922    S X=$$FOR MAT(VAPA(8 ))_U_$$FOR MAT($$GET1 ^DIQ(2,DFN _",",.134) )_U_$$FORM AT($$GET1^ DIQ(2,DFN_ ",",.132))
  10923   "RTN","VPR DJ00",142, 0)
  10924    S NM="H^M C^WP" F P= 1:1:3 I $L ($P(X,U,P) ) D
  10925   "RTN","VPR DJ00",143, 0)
  10926    . S I=$P( NM,U,P),PA T("telecom s",P,"usag eCode")=I
  10927   "RTN","VPR DJ00",144, 0)
  10928    . S PAT(" telecoms", P,"usageNa me")=$S(I= "WP":"work  place",I= "MC":"mobi le contact ",1:"home  address")
  10929   "RTN","VPR DJ00",145, 0)
  10930    . S PAT(" telecoms", P,"telecom ")=$P(X,U, P)
  10931   "RTN","VPR DJ00",146, 0)
  10932    Q
  10933   "RTN","VPR DJ00",147, 0)
  10934   SUPP ;-sup port conta cts
  10935   "RTN","VPR DJ00",148, 0)
  10936    N VAOA,A, I,X,TYPE,S
  10937   "RTN","VPR DJ00",149, 0)
  10938    S S=0 F A ="",1 K VA OA D
  10939   "RTN","VPR DJ00",150, 0)
  10940    . S:A VAO A("A")=A D  OAD^VADPT  Q:'$L($G( VAOA(9)))
  10941   "RTN","VPR DJ00",151, 0)
  10942    . S S=S+1 ,TYPE=$S(A =1:"ECON^E mergency C ontact",1: "NOK^Next  of Kin")
  10943   "RTN","VPR DJ00",152, 0)
  10944    . S PAT(" supports", S,"contact TypeCode") ="urn:va:p at-contact :"_$P(TYPE ,U)
  10945   "RTN","VPR DJ00",153, 0)
  10946    . S PAT(" supports", S,"contact TypeName") =$P(TYPE,U ,2)
  10947   "RTN","VPR DJ00",154, 0)
  10948    . S:$L(VA OA(9)) PAT ("supports ",S,"name" )=VAOA(9)
  10949   "RTN","VPR DJ00",155, 0)
  10950    . S:$L(VA OA(10)) PA T("support s",S,"rela tionship") =VAOA(10)
  10951   "RTN","VPR DJ00",156, 0)
  10952    . S:$L(VA OA(1)) PAT ("supports ",S,"addre sses",1,"s treetLine1 ")=VAOA(1)
  10953   "RTN","VPR DJ00",157, 0)
  10954    . S X=VAO A(2) I $L( X),$L(VAOA (3)) S X=X _" "_VAOA( 3)
  10955   "RTN","VPR DJ00",158, 0)
  10956    . S:$L(X)  PAT("supp orts",S,"a ddresses", 1,"streetL ine2")=X
  10957   "RTN","VPR DJ00",159, 0)
  10958    . S:$L(VA OA(4)) PAT ("supports ",S,"addre sses",1,"c ity")=VAOA (4)
  10959   "RTN","VPR DJ00",160, 0)
  10960    . S X=$P( VAOA(5),U, 2) S:$L(X)  PAT("supp orts",S,"a ddresses", 1,"statePr ovince")=X
  10961   "RTN","VPR DJ00",161, 0)
  10962    . S X=$P( VAOA(11),U ,2) S:$L(X ) PAT("sup ports",S," addresses" ,1,"postal Code")=X
  10963   "RTN","VPR DJ00",162, 0)
  10964    . S I=$S( A=1:.33011 ,1:.21011) ,X=$$FORMA T(VAOA(8)) _U_U_$$FOR MAT($$GET1 ^DIQ(2,DFN _",",I))
  10965   "RTN","VPR DJ00",163, 0)
  10966    . ; X=hom e^cell^wor k phones
  10967   "RTN","VPR DJ00",164, 0)
  10968    . S NM="H ^MC^WP" F  P=1:1:3 I  $L($P(X,U, P)) D
  10969   "RTN","VPR DJ00",165, 0)
  10970    .. S I=$P (NM,U,P),P AT("suppor ts",S,"tel ecomList", P,"usageCo de")=I
  10971   "RTN","VPR DJ00",166, 0)
  10972    .. S PAT( "supports" ,S,"teleco mList",P," usageName" )=$S(I="WP ":"work pl ace",I="MC ":"mobile  contact",1 :"home add ress")
  10973   "RTN","VPR DJ00",167, 0)
  10974    .. S PAT( "supports" ,S,"teleco mList",P," telecom")= $P(X,U,P)
  10975   "RTN","VPR DJ00",168, 0)
  10976    Q
  10977   "RTN","VPR DJ00",169, 0)
  10978   ALIAS ;-ot her names  used
  10979   "RTN","VPR DJ00",170, 0)
  10980    N I,X
  10981   "RTN","VPR DJ00",171, 0)
  10982    S I=0 F   S I=$O(^DP T(DFN,.01, I)) Q:I<1   S X=$G(^( I,0)) D
  10983   "RTN","VPR DJ00",172, 0)
  10984    . S PAT(" aliases",I ,"fullName ")=$P(X,U)
  10985   "RTN","VPR DJ00",173, 0)
  10986    Q
  10987   "RTN","VPR DJ00",174, 0)
  10988   FAC ;-trea ting facil ities [see  FACLIST^O RWCIRN]
  10989   "RTN","VPR DJ00",175, 0)
  10990    N IFN S D FN=+$G(DFN ) Q:DFN<1
  10991   "RTN","VPR DJ00",176, 0)
  10992    N VPRY,HO ME,LAST,I, X,IEN,VASI TE
  10993   "RTN","VPR DJ00",177, 0)
  10994    S X=$$ALL ^VASITE ;V ASITE(stn# )=stn# for  all local
  10995   "RTN","VPR DJ00",178, 0)
  10996    I $L($T(T FL^VAFCTFU 1)) D TFL^ VAFCTFU1(. VPRY,DFN)
  10997   "RTN","VPR DJ00",179, 0)
  10998    S HOME=+$ P($G(^DPT( DFN,"MPI") ),U,3) ;ho me facilit y
  10999   "RTN","VPR DJ00",180, 0)
  11000    I $P($G(V PRY(1)),U) <0 D  ;not  setup
  11001   "RTN","VPR DJ00",181, 0)
  11002    . S X=$O( ^AUPNVSIT( "AA",DFN,0 )),LAST=$S (X:9999999 -$P(X,".") ,1:"")
  11003   "RTN","VPR DJ00",182, 0)
  11004    . S X=$$S ITE^VASITE
  11005   "RTN","VPR DJ00",183, 0)
  11006    . S VPRY( 1)=$P(X,U, 3)_U_$P(X, U,2)_U_LAS T_U_$$GET1 ^DIQ(4,+X_ ",",60)
  11007   "RTN","VPR DJ00",184, 0)
  11008    S I=0 F   S I=$O(VPR Y(I)) Q:I< 1  D
  11009   "RTN","VPR DJ00",185, 0)
  11010    . S X=VPR Y(I) Q:$P( X,U)=""  ; unknown
  11011   "RTN","VPR DJ00",186, 0)
  11012    . S IEN=+ $$IEN^XUAF 4($P(X,U))
  11013   "RTN","VPR DJ00",187, 0)
  11014    . I +X=77 6!(+X=200)  S $P(X,U, 2)="DEPT.  OF DEFENSE "
  11015   "RTN","VPR DJ00",188, 0)
  11016    . S PAT(" facilities ",I,"code" )=$P(X,U)     ;stn#
  11017   "RTN","VPR DJ00",189, 0)
  11018    . S PAT(" facilities ",I,"name" )=$P(X,U,2 )  ;name
  11019   "RTN","VPR DJ00",190, 0)
  11020    . S:IEN=H OME PAT("f acilities" ,I,"homeSi te")="true "
  11021   "RTN","VPR DJ00",191, 0)
  11022    . S:$L($P (X,U,3)) P AT("facili ties",I,"l atestDate" )=$$JSONDT ^VPRUTILS( $P($P(X,U, 3),"."))
  11023   "RTN","VPR DJ00",192, 0)
  11024    . I $D(VA SITE(+X))  D
  11025   "RTN","VPR DJ00",193, 0)
  11026    .. S PAT( "facilitie s",I,"loca lPatientId ")=DFN
  11027   "RTN","VPR DJ00",194, 0)
  11028    .. S PAT( "facilitie s",I,"syst emId")=VPR SYS
  11029   "RTN","VPR DJ00",195, 0)
  11030    Q
  11031   "RTN","VPR DJ00",196, 0)
  11032   PC ;-prima ry care as signments
  11033   "RTN","VPR DJ00",197, 0)
  11034    N X S X=$ $OUTPTPR^S DUTL3(DFN)  I X D
  11035   "RTN","VPR DJ00",198, 0)
  11036    . S PAT(" pcProvider Uid")=$$SE TUID^VPRUT ILS("user" ,,+X)
  11037   "RTN","VPR DJ00",199, 0)
  11038    . S PAT(" pcProvider Name")=$P( X,U,2)
  11039   "RTN","VPR DJ00",200, 0)
  11040    S X=$$OUT PTTM^SDUTL 3(DFN) I X  D
  11041   "RTN","VPR DJ00",201, 0)
  11042    . S PAT(" pcTeamUid" )=$$SETUID ^VPRUTILS( "team",,+X )
  11043   "RTN","VPR DJ00",202, 0)
  11044    . S PAT(" pcTeamName ")=$$GET1^ DIQ(404.51 ,+X_",",.0 1)
  11045   "RTN","VPR DJ00",203, 0)
  11046    Q
  11047   "RTN","VPR DJ00",204, 0)
  11048    ;
  11049   "RTN","VPR DJ00",205, 0)
  11050   FORMAT(X)  ; -- enfor ce (xxx)xx x-xxxx pho ne format
  11051   "RTN","VPR DJ00",206, 0)
  11052    S X=$G(X)  I X?1"("3 N1")"3N1"- "4N.E Q X
  11053   "RTN","VPR DJ00",207, 0)
  11054    N P,N,I,Y  S P=""
  11055   "RTN","VPR DJ00",208, 0)
  11056    F I=1:1:$ L(X) S N=$ E(X,I) I N =+N S P=P_ N
  11057   "RTN","VPR DJ00",209, 0)
  11058    S:$L(P)<1 0 P=$E("00 00000000", 1,10-$L(P) )_P
  11059   "RTN","VPR DJ00",210, 0)
  11060    S Y=$S(P: "("_$E(P,1 ,3)_")"_$E (P,4,6)_"- "_$E(P,7,1 0),1:"")
  11061   "RTN","VPR DJ00",211, 0)
  11062    Q Y
  11063   "RTN","VPR DJ00",212, 0)
  11064    ;
  11065   "RTN","VPR DJ00",213, 0)
  11066   NAME(CODE, SET) ; --  Return exp anded name  for code  set
  11067   "RTN","VPR DJ00",214, 0)
  11068    N Y S Y=" ",CODE=$G( CODE)
  11069   "RTN","VPR DJ00",215, 0)
  11070    I $G(SET) ="gender"  S Y=$S(COD E="F":"Fem ale",CODE= "M":"Male" ,1:"Unknow n")
  11071   "RTN","VPR DJ00",216, 0)
  11072    I $G(SET) ="maritalS tatus" S Y =$S(CODE=" D":"Divorc ed",CODE=" M":"Marrie d",CODE="W ":"Widowed ",CODE="L" :"Legally  Separated" ,CODE="S": "Never Mar ried",1:"U nknown")
  11073   "RTN","VPR DJ00",217, 0)
  11074    I $G(SET) ="religion " S Y=$$GE T1^DIQ(13, CODE_",",. 01)
  11075   "RTN","VPR DJ00",218, 0)
  11076    Q Y
  11077   "RTN","VPR DJ00",219, 0)
  11078    ;
  11079   "RTN","VPR DJ00",220, 0)
  11080   BOOL(X) ;
  11081   "RTN","VPR DJ00",221, 0)
  11082    Q $S(X>0: "true",1:" false")
  11083   "RTN","VPR DJ01")
  11084   0^71^B4120 9021
  11085   "RTN","VPR DJ01",1,0)
  11086   VPRDJ01 ;S LC/MKB --  Orders ;6/ 25/12  16: 11
  11087   "RTN","VPR DJ01",2,0)
  11088    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  11089   "RTN","VPR DJ01",3,0)
  11090    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  11091   "RTN","VPR DJ01",4,0)
  11092    ;
  11093   "RTN","VPR DJ01",5,0)
  11094    ; Externa l Referenc es           DBIA#
  11095   "RTN","VPR DJ01",6,0)
  11096    ; ------- ---------- --           -----
  11097   "RTN","VPR DJ01",7,0)
  11098    ; ^DPT                            10035
  11099   "RTN","VPR DJ01",8,0)
  11100    ; ^OR(100                          5771
  11101   "RTN","VPR DJ01",9,0)
  11102    ; ^ORA(10 2.4                      5769
  11103   "RTN","VPR DJ01",10,0 )
  11104    ; ^ORD(10 0.98                      873
  11105   "RTN","VPR DJ01",11,0 )
  11106    ; ^PXRMIN DX                       4290
  11107   "RTN","VPR DJ01",12,0 )
  11108    ; ^RADPT                           2480
  11109   "RTN","VPR DJ01",13,0 )
  11110    ; ^SC                             10040
  11111   "RTN","VPR DJ01",14,0 )
  11112    ; ^VA(200                         10060
  11113   "RTN","VPR DJ01",15,0 )
  11114    ; DIC                              2051
  11115   "RTN","VPR DJ01",16,0 )
  11116    ; DIQ                              2056
  11117   "RTN","VPR DJ01",17,0 )
  11118    ; GMRCGUI B                        2980
  11119   "RTN","VPR DJ01",18,0 )
  11120    ; LR7OU1                           2955
  11121   "RTN","VPR DJ01",19,0 )
  11122    ; ORQ1,^T MP("ORR"                 3154
  11123   "RTN","VPR DJ01",20,0 )
  11124    ; ORQ12,^ TMP("ORR"                5704
  11125   "RTN","VPR DJ01",21,0 )
  11126    ; ORX8                             2467
  11127   "RTN","VPR DJ01",22,0 )
  11128    ; PSS51P1                          4546
  11129   "RTN","VPR DJ01",23,0 )
  11130    ;
  11131   "RTN","VPR DJ01",24,0 )
  11132    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  11133   "RTN","VPR DJ01",25,0 )
  11134    ;
  11135   "RTN","VPR DJ01",26,0 )
  11136   OR1(ID) ;  -- order I D >> ^TMP( "ORR",$J,O RLIST,VPRN )
  11137   "RTN","VPR DJ01",27,0 )
  11138    N ORDER,C HILD,VPRC
  11139   "RTN","VPR DJ01",28,0 )
  11140    D ORX(ID, .ORDER)
  11141   "RTN","VPR DJ01",29,0 )
  11142    S VPRC=0  F  S VPRC= $O(^OR(100 ,ID,2,VPRC )) Q:VPRC< 1  D
  11143   "RTN","VPR DJ01",30,0 )
  11144    . K CHILD  D ORX(VPR C,.CHILD)
  11145   "RTN","VPR DJ01",31,0 )
  11146    . M ORDER ("children ",VPRC)=CH ILD
  11147   "RTN","VPR DJ01",32,0 )
  11148    D ADD^VPR DJ("ORDER" ,"order")
  11149   "RTN","VPR DJ01",33,0 )
  11150    Q
  11151   "RTN","VPR DJ01",34,0 )
  11152   ORX(IFN,OR D) ; -- ex tract orde r IFN into  ORD("attr ibute")
  11153   "RTN","VPR DJ01",35,0 )
  11154    N ORLIST, ORLST,X0,X 8,LOC,X,I, DA
  11155   "RTN","VPR DJ01",36,0 )
  11156    S ORLST=$ S(+$G(VPRN ):VPRN-1,1 :0) S:'$D( ORLIST) OR LIST=$H
  11157   "RTN","VPR DJ01",37,0 )
  11158    D GET^ORQ 12(IFN,ORL IST,1)
  11159   "RTN","VPR DJ01",38,0 )
  11160    S X0=$G(^ TMP("ORR", $J,ORLIST, ORLST))
  11161   "RTN","VPR DJ01",39,0 )
  11162    N $ES,$ET ,ERRPAT,ER RMSG
  11163   "RTN","VPR DJ01",40,0 )
  11164    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  11165   "RTN","VPR DJ01",41,0 )
  11166    S ERRMSG= "A problem  occurred  converting  record "_ IFN_" for  the orders  domain"
  11167   "RTN","VPR DJ01",42,0 )
  11168    ;
  11169   "RTN","VPR DJ01",43,0 )
  11170    S ORD("lo calId")=IF N,ORD("uid ")=$$SETUI D^VPRUTILS ("order",D FN,IFN)
  11171   "RTN","VPR DJ01",44,0 )
  11172    S X=$$OI^ ORX8(+X0)  I $L(X) D
  11173   "RTN","VPR DJ01",45,0 )
  11174    . N ARRAY ,NAME
  11175   "RTN","VPR DJ01",46,0 )
  11176    . S ARRAY ("Code")=1 _U_"oi",AR RAY("Name" )=2,ARRAY( "PackageRe f")=3
  11177   "RTN","VPR DJ01",47,0 )
  11178    . D SPLIT VAL^VPRUTI LS(X,.ARRA Y) S ORD(" name")=ARR AY("Name")
  11179   "RTN","VPR DJ01",48,0 )
  11180    . S NAME= "" F  S NA ME=$O(ARRA Y(NAME)) Q :NAME=""   S ORD("oi" _NAME)=$G( ARRAY(NAME ))
  11181   "RTN","VPR DJ01",49,0 )
  11182    S ORD("di splayGroup ")=$P(X0,U ,2)
  11183   "RTN","VPR DJ01",50,0 )
  11184    S ORD("en tered")=$$ JSONDT^VPR UTILS($P(X 0,U,3))
  11185   "RTN","VPR DJ01",51,0 )
  11186    S ORD("st art")=$$TM ($P(X0,U,4 )),ORD("st op")=$$TM( $P(X0,U,5) )
  11187   "RTN","VPR DJ01",52,0 )
  11188    S ORD("st atusCode") ="urn:va:o rder-statu s:"_$P(X0, U,7)
  11189   "RTN","VPR DJ01",53,0 )
  11190    S ORD("st atusName") =$P(X0,U,6 )
  11191   "RTN","VPR DJ01",54,0 )
  11192    S ORD("st atusVuid") ="urn:va:v uid:"_$$ST S^VPRDOR($ P(X0,U,7))
  11193   "RTN","VPR DJ01",55,0 )
  11194    D SETTEXT ^VPRUTILS( $NA(^TMP(" ORR",$J,OR LIST,ORLST ,"TX")),$N A(^TMP("VP RTEXT",$J, IFN)))
  11195   "RTN","VPR DJ01",56,0 )
  11196    M ORD("co ntent","\" )=^TMP("VP RTEXT",$J, IFN)
  11197   "RTN","VPR DJ01",57,0 )
  11198    S X=$$GET 1^DIQ(100, IFN_",",1, "I") I X D
  11199   "RTN","VPR DJ01",58,0 )
  11200    . S ORD(" providerUi d")=$$SETU ID^VPRUTIL S("user",, +X)
  11201   "RTN","VPR DJ01",59,0 )
  11202    . S ORD(" providerNa me")=$P($G (^VA(200,+ X,0)),U)
  11203   "RTN","VPR DJ01",60,0 )
  11204    S LOC=+$$ GET1^DIQ(1 00,IFN_"," ,6,"I"),FA C=$$FAC^VP RD(LOC) I  LOC D
  11205   "RTN","VPR DJ01",61,0 )
  11206    . S ORD(" locationNa me")=$P($G (^SC(LOC,0 )),U)
  11207   "RTN","VPR DJ01",62,0 )
  11208    . S ORD(" locationUi d")=$$SETU ID^VPRUTIL S("locatio n",,LOC)
  11209   "RTN","VPR DJ01",63,0 )
  11210    D FACILIT Y^VPRUTILS (FAC,"ORD" )
  11211   "RTN","VPR DJ01",64,0 )
  11212    S ORD("se rvice")=$$ GET1^DIQ(1 00,IFN_"," ,"12:1")
  11213   "RTN","VPR DJ01",65,0 )
  11214    S X=$$GET 1^DIQ(100, IFN_",",9, "I") S:X O RD("predec essor")=$$ SETUID^VPR UTILS("ord er",DFN,+X )
  11215   "RTN","VPR DJ01",66,0 )
  11216    S X=$$GET 1^DIQ(100, IFN_",",9. 1,"I") S:X  ORD("succ essor")=$$ SETUID^VPR UTILS("ord er",DFN,+X )
  11217   "RTN","VPR DJ01",67,0 )
  11218    D RESULTS
  11219   "RTN","VPR DJ01",68,0 )
  11220    ; sign/ve rify
  11221   "RTN","VPR DJ01",69,0 )
  11222    S X8=$G(^ OR(100,IFN ,8,1,0)),I =0 I $P(X8 ,U,6) D        ;signe d
  11223   "RTN","VPR DJ01",70,0 )
  11224    . N PROV  S PROV=$P( X8,U,5) S: PROV<1 PRO V=$P(X8,U, 3)  ;if on  chart,
  11225   "RTN","VPR DJ01",71,0 )
  11226    . D USER( .I,"S",PRO V,$P(X8,U, 6))                       ;   us e provider
  11227   "RTN","VPR DJ01",72,0 )
  11228    I $P(X8,U ,9)  D USE R(.I,"N",$ P(X8,U,8), $P(X8,U,9) )   ;nurse
  11229   "RTN","VPR DJ01",73,0 )
  11230    I $P(X8,U ,11) D USE R(.I,"C",$ P(X8,U,10) ,$P(X8,U,1 1)) ;clerk
  11231   "RTN","VPR DJ01",74,0 )
  11232    I $P(X8,U ,19) D USE R(.I,"R",$ P(X8,U,18) ,$P(X8,U,1 9)) ;chart  review
  11233   "RTN","VPR DJ01",75,0 )
  11234    Q
  11235   "RTN","VPR DJ01",76,0 )
  11236    ; acknowl edgements
  11237   "RTN","VPR DJ01",77,0 )
  11238    S DA=0 F   S DA=$O(^ ORA(102.4, "B",+IFN,D A)) Q:DA<1   D
  11239   "RTN","VPR DJ01",78,0 )
  11240    . S X0=$G (^ORA(102. 4,DA,0)) Q :'$P(X0,U, 3)  ;stub  - not ack' d
  11241   "RTN","VPR DJ01",79,0 )
  11242    . S X=+$P (X0,U,2),X =$S(X:X_U_ $P($G(^VA( 200,X,0)), U),1:U)
  11243   "RTN","VPR DJ01",80,0 )
  11244    . S ORD(" acknowledg ement",DA) =X_U_$P(X0 ,U,3)
  11245   "RTN","VPR DJ01",81,0 )
  11246    Q
  11247   "RTN","VPR DJ01",82,0 )
  11248    ;
  11249   "RTN","VPR DJ01",83,0 )
  11250   RESULTS ;  -- add ORD ("results" ,n,"uid")  list
  11251   "RTN","VPR DJ01",84,0 )
  11252    N ORPK,OR PKG,ORDG
  11253   "RTN","VPR DJ01",85,0 )
  11254    S ORPK=$G (^OR(100,I FN,4)),ORP KG=ORD("se rvice"),OR DG=ORD("di splayGroup ")
  11255   "RTN","VPR DJ01",86,0 )
  11256    I ORPKG=" GMRC" D  Q
  11257   "RTN","VPR DJ01",87,0 )
  11258    . N VPRD, I,N,X D DO CLIST^GMRC GUIB(.VPRD ,+ORPK)
  11259   "RTN","VPR DJ01",88,0 )
  11260    . S N=1,O RD("result s",N,"uid" )=$$SETUID ^VPRUTILS( "consult", DFN,+ORPK)
  11261   "RTN","VPR DJ01",89,0 )
  11262    . S I=0 F   S I=$O(V PRD(50,I))  Q:I<1  S  X=$G(VPRD( 50,I)) D
  11263   "RTN","VPR DJ01",90,0 )
  11264    .. Q:'$D( @(U_$P(X," ;",2)_+X_" )"))  ;tex t deleted
  11265   "RTN","VPR DJ01",91,0 )
  11266    .. S N=N+ 1,ORD("res ults",N,"u id")=$$SET UID^VPRUTI LS("docume nt",DFN,+X )
  11267   "RTN","VPR DJ01",92,0 )
  11268    . Q:ORDG' ="PROC"
  11269   "RTN","VPR DJ01",93,0 )
  11270    . N VPRC  D FIND^DIC (702,,"@", "Q",+ORPK, ,"ACON",,, "VPRC") ;C P
  11271   "RTN","VPR DJ01",94,0 )
  11272    . S I=0 F   S I=$O(V PRC("DILIS T",2,I)) Q :I<1  D
  11273   "RTN","VPR DJ01",95,0 )
  11274    .. S X=+$ G(VPRC("DI LIST",2,I) )_";MDD(70 2,"
  11275   "RTN","VPR DJ01",96,0 )
  11276    .. S N=N+ 1,ORD("res ults",N,"u id")=$$SET UID^VPRUTI LS("proced ure",DFN,X )
  11277   "RTN","VPR DJ01",97,0 )
  11278    I ORPKG=" LR" D  Q
  11279   "RTN","VPR DJ01",98,0 )
  11280    . Q:$L(OR PK,";")'>3   ;no resu lts yet, o r parent o rder
  11281   "RTN","VPR DJ01",99,0 )
  11282    . N SUB,I DT,CDT,ITM ,VPRT,ID,T ,N,LRDFN,I DX
  11283   "RTN","VPR DJ01",100, 0)
  11284    . S SUB=$ P(ORPK,";" ,4),IDT=$P (ORPK,";", 5),CDT=999 9999-IDT
  11285   "RTN","VPR DJ01",101, 0)
  11286    . I SUB=" CH" D  Q
  11287   "RTN","VPR DJ01",102, 0)
  11288    .. S ITM= +$G(ORD("o iPackageRe f")) D EXP AND^LR7OU1 (ITM,.VPRT )
  11289   "RTN","VPR DJ01",103, 0)
  11290    .. S (T,N )=0 F  S T =$O(VPRT(T )) Q:T<1   S ID=$O(^P XRMINDX(63 ,"PI",DFN, T,CDT,""))  I $L(ID)  S N=N+1,OR D("results ",N,"uid") =$$SETUID^ VPRUTILS(" lab",DFN,$ P(ID,";",2 ,9))
  11291   "RTN","VPR DJ01",104, 0)
  11292    . I SUB=" MI" D  Q
  11293   "RTN","VPR DJ01",105, 0)
  11294    .. S ITM= "M;A;",N=0 ,LRDFN=$G( ^DPT(DFN," LR"))
  11295   "RTN","VPR DJ01",106, 0)
  11296    .. F  S I TM=$O(^PXR MINDX(63," PI",DFN,IT M)) Q:$E(I TM,1,4)'=" M;A;"  I $ D(^(ITM,CD T)) D
  11297   "RTN","VPR DJ01",107, 0)
  11298    ... S IDX =LRDFN_";M I;"_IDT
  11299   "RTN","VPR DJ01",108, 0)
  11300    ... F  S  IDX=$O(^PX RMINDX(63, "PI",DFN,I TM,CDT,IDX )) Q:IDX=" "  S ID=$P (IDX,";",2 ,99),N=N+1 ,ORD("resu lts",N,"ui d")=$$SETU ID^VPRUTIL S("lab",DF N,ID)
  11301   "RTN","VPR DJ01",109, 0)
  11302    .. S N=N+ 1,ORD("res ults",N,"u id")=$$SET UID^VPRUTI LS("docume nt",DFN,SU B_";"_IDT)
  11303   "RTN","VPR DJ01",110, 0)
  11304    . ; SUB:" AP" [AU,CY ,EM,SP]
  11305   "RTN","VPR DJ01",111, 0)
  11306    . S ORD(" results",1 ,"uid")=$$ SETUID^VPR UTILS("lab ",DFN,SUB_ ";"_IDT)
  11307   "RTN","VPR DJ01",112, 0)
  11308    . S ORD(" results",2 ,"uid")=$$ SETUID^VPR UTILS("doc ument",DFN ,SUB_";"_I DT)
  11309   "RTN","VPR DJ01",113, 0)
  11310    I ORPKG[" PS" D  Q
  11311   "RTN","VPR DJ01",114, 0)
  11312    . S:ORPK  ORD("resul ts",1,"uid ")=$$SETUI D^VPRUTILS ("med",DFN ,IFN)
  11313   "RTN","VPR DJ01",115, 0)
  11314    I ORPKG=" RA" D  Q
  11315   "RTN","VPR DJ01",116, 0)
  11316    . N IDT,C N S IDT=+$ O(^RADPT(" AO",+ORPK, DFN,0)) Q: 'IDT
  11317   "RTN","VPR DJ01",117, 0)
  11318    . S CN=0  F  S CN=$O (^RADPT("A O",+ORPK,D FN,IDT,CN) ) Q:CN<1   S ORD("res ults",CN," uid")=$$SE TUID^VPRUT ILS("image ",DFN,IDT_ "-"_CN)
  11319   "RTN","VPR DJ01",118, 0)
  11320    ; rest sh ould be ge neric (OR)  orders
  11321   "RTN","VPR DJ01",119, 0)
  11322    I ORDG="N TX" S ORD( "results", 1,"uid")=$ $SETUID^VP RUTILS("tr eatment",D FN,IFN) Q
  11323   "RTN","VPR DJ01",120, 0)
  11324    I ORDG="V /M" Q  ;no  link
  11325   "RTN","VPR DJ01",121, 0)
  11326    Q
  11327   "RTN","VPR DJ01",122, 0)
  11328    ;
  11329   "RTN","VPR DJ01",123, 0)
  11330   NTX1(IFN)  ; -- extra ct nursing  treatment  order IFN  into NTX( "attribute ")
  11331   "RTN","VPR DJ01",124, 0)
  11332    N NTX,X
  11333   "RTN","VPR DJ01",125, 0)
  11334    D ORX(IFN ,.NTX) ;ge t basic or der info
  11335   "RTN","VPR DJ01",126, 0)
  11336    S NTX("or derUid")=N TX("uid")
  11337   "RTN","VPR DJ01",127, 0)
  11338    S NTX("ui d")=$$SETU ID^VPRUTIL S("treatme nt",DFN,IF N)
  11339   "RTN","VPR DJ01",128, 0)
  11340    S X=$$VAL UE^ORX8(IF N,"COMMENT ") S:$L(X)  NTX("inst ructions") =X
  11341   "RTN","VPR DJ01",129, 0)
  11342    S X=$$VAL UE^ORX8(IF N,"SCHEDUL E") I X D
  11343   "RTN","VPR DJ01",130, 0)
  11344    . D ZERO^ PSS51P1(X, ,,,"VPRS")
  11345   "RTN","VPR DJ01",131, 0)
  11346    . S NTX(" scheduleNa me")=$G(^T MP($J,"VPR S",X,.01))
  11347   "RTN","VPR DJ01",132, 0)
  11348    . S NTX(" adminTimes ")=$G(^TMP ($J,"VPRS" ,X,1))
  11349   "RTN","VPR DJ01",133, 0)
  11350    . K ^TMP( $J,"VPRS")
  11351   "RTN","VPR DJ01",134, 0)
  11352    D ADD^VPR DJ("NTX"," treatment" )
  11353   "RTN","VPR DJ01",135, 0)
  11354    Q
  11355   "RTN","VPR DJ01",136, 0)
  11356    ;
  11357   "RTN","VPR DJ01",137, 0)
  11358   USER(N,ROL E,IEN,DATE ) ; -- add  signature /verificat ion data
  11359   "RTN","VPR DJ01",138, 0)
  11360    S N=+$G(N )+1
  11361   "RTN","VPR DJ01",139, 0)
  11362    S ORD("cl inicians", N,"signedD ateTime")= $$JSONDT^V PRUTILS(DA TE)
  11363   "RTN","VPR DJ01",140, 0)
  11364    S ORD("cl inicians", N,"role")= $G(ROLE)
  11365   "RTN","VPR DJ01",141, 0)
  11366    Q:+$G(IEN )<1
  11367   "RTN","VPR DJ01",142, 0)
  11368    S ORD("cl inicians", N,"uid")=$ $SETUID^VP RUTILS("us er",,IEN)
  11369   "RTN","VPR DJ01",143, 0)
  11370    S ORD("cl inicians", N,"name")= $P($G(^VA( 200,IEN,0) ),U)
  11371   "RTN","VPR DJ01",144, 0)
  11372    Q
  11373   "RTN","VPR DJ01",145, 0)
  11374    ;
  11375   "RTN","VPR DJ01",146, 0)
  11376   TM(X) ; --  strip sec onds off a  FM time
  11377   "RTN","VPR DJ01",147, 0)
  11378    N D,T,Y S  D=$P(X,". "),T=$P(X, ".",2)
  11379   "RTN","VPR DJ01",148, 0)
  11380    S Y=D_$S( T:"."_$E(T ,1,4),1:"" )
  11381   "RTN","VPR DJ01",149, 0)
  11382    S Y=$$JSO NDT^VPRUTI LS(Y)
  11383   "RTN","VPR DJ01",150, 0)
  11384    Q Y
  11385   "RTN","VPR DJ02")
  11386   0^72^B6500 3415
  11387   "RTN","VPR DJ02",1,0)
  11388   VPRDJ02 ;S LC/MKB --  Problems,A llergies,V itals ;6/2 5/12  16:1 1
  11389   "RTN","VPR DJ02",2,0)
  11390    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  11391   "RTN","VPR DJ02",3,0)
  11392    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  11393   "RTN","VPR DJ02",4,0)
  11394    ;
  11395   "RTN","VPR DJ02",5,0)
  11396    ; Externa l Referenc es           DBIA#
  11397   "RTN","VPR DJ02",6,0)
  11398    ; ------- ---------- --           -----
  11399   "RTN","VPR DJ02",7,0)
  11400    ; ^PXRMIN DX                       4290
  11401   "RTN","VPR DJ02",8,0)
  11402    ; ^SC                             10040
  11403   "RTN","VPR DJ02",9,0)
  11404    ; DIC                              2051
  11405   "RTN","VPR DJ02",10,0 )
  11406    ; DIQ                              2056
  11407   "RTN","VPR DJ02",11,0 )
  11408    ; GMPLUTL 2                        2741
  11409   "RTN","VPR DJ02",12,0 )
  11410    ; GMRADPT                         10099
  11411   "RTN","VPR DJ02",13,0 )
  11412    ; GMRAOR2                          2422
  11413   "RTN","VPR DJ02",14,0 )
  11414    ; GMRVUT0 ,^UTILITY( $J            1446
  11415   "RTN","VPR DJ02",15,0 )
  11416    ; GMVGETQ L                        5048
  11417   "RTN","VPR DJ02",16,0 )
  11418    ; GMVGETV T                        5047
  11419   "RTN","VPR DJ02",17,0 )
  11420    ; GMVUTL                           5046
  11421   "RTN","VPR DJ02",18,0 )
  11422    ; ICDCODE                          3990
  11423   "RTN","VPR DJ02",19,0 )
  11424    ; XLFSTR                          10104
  11425   "RTN","VPR DJ02",20,0 )
  11426    ; XUAF4                            2171
  11427   "RTN","VPR DJ02",21,0 )
  11428    ;
  11429   "RTN","VPR DJ02",22,0 )
  11430    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  11431   "RTN","VPR DJ02",23,0 )
  11432    ;
  11433   "RTN","VPR DJ02",24,0 )
  11434   GMPL1(ID)  ; -- probl em
  11435   "RTN","VPR DJ02",25,0 )
  11436    N VPRL,PR OB,X,I,DAT E,USER,FAC
  11437   "RTN","VPR DJ02",26,0 )
  11438    D DETAIL^ GMPLUTL2(I D,.VPRL) Q :'$D(VPRL)   ;doesn't  exist
  11439   "RTN","VPR DJ02",27,0 )
  11440    N $ES,$ET ,ERRPAT,ER RMSG
  11441   "RTN","VPR DJ02",28,0 )
  11442    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  11443   "RTN","VPR DJ02",29,0 )
  11444    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he problem  domain"
  11445   "RTN","VPR DJ02",30,0 )
  11446    ;
  11447   "RTN","VPR DJ02",31,0 )
  11448    S PROB("u id")=$$SET UID^VPRUTI LS("proble m",DFN,ID) ,PROB("loc alId")=ID
  11449   "RTN","VPR DJ02",32,0 )
  11450    S PROB("p roblemText ")=$G(VPRL ("NARRATIV E"))
  11451   "RTN","VPR DJ02",33,0 )
  11452    S DATE=$P ($G(VPRL(" ENTERED")) ,U)
  11453   "RTN","VPR DJ02",34,0 )
  11454    S:$L(DATE ) DATE=$$D ATE^VPRDGM PL(DATE),P ROB("enter ed")=$$JSO NDT^VPRUTI LS(DATE)
  11455   "RTN","VPR DJ02",35,0 )
  11456    S X=$G(VP RL("DIAGNO SIS")) I $ L(X) D
  11457   "RTN","VPR DJ02",36,0 )
  11458    . N ICD9Z N,DIAG
  11459   "RTN","VPR DJ02",37,0 )
  11460    . I DATE' >0 S DATE= DT
  11461   "RTN","VPR DJ02",38,0 )
  11462    . S ICD9Z N=$$ICDDX^ ICDCODE(X, DATE),DIAG =$S($P($G( ICD9ZN),U, 4)'="":$P( ICD9ZN,U,4 ),1:X)
  11463   "RTN","VPR DJ02",39,0 )
  11464    . S PROB( "icdCode") =$$SETNCS^ VPRUTILS(" icd",X),PR OB("icdNam e")=DIAG
  11465   "RTN","VPR DJ02",40,0 )
  11466    S X=$G(VP RL("ONSET" )) S:$L(X)  X=$$DATE^ VPRDGMPL(X ),PROB("on set")=$$JS ONDT^VPRUT ILS(X)
  11467   "RTN","VPR DJ02",41,0 )
  11468    S X=$G(VP RL("MODIFI ED")) S:$L (X) X=$$DA TE^VPRDGMP L(X),PROB( "updated") =$$JSONDT^ VPRUTILS(X )
  11469   "RTN","VPR DJ02",42,0 )
  11470    S X=$G(VP RL("STATUS ")) I $L(X ) D
  11471   "RTN","VPR DJ02",43,0 )
  11472    . S PROB( "statusNam e")=X,X=$E (X)
  11473   "RTN","VPR DJ02",44,0 )
  11474    . S X=$S( X="A":5556 1003,X="I" :73425007, 1:"")
  11475   "RTN","VPR DJ02",45,0 )
  11476    . S PROB( "statusCod e")=$$SETN CS^VPRUTIL S("sct",X)
  11477   "RTN","VPR DJ02",46,0 )
  11478    S X=$G(VP RL("PRIORI TY")) I X] "" D
  11479   "RTN","VPR DJ02",47,0 )
  11480    . S X=$$L OW^XLFSTR( X),PROB("a cuityName" )=X
  11481   "RTN","VPR DJ02",48,0 )
  11482    . S PROB( "acuityCod e")=$$SETV URN^VPRUTI LS("prob-a cuity",$E( X))
  11483   "RTN","VPR DJ02",49,0 )
  11484    S X=$$GET 1^DIQ(9000 011,ID_"," ,1.07,"I")  S:X PROB( "resolved" )=$$JSONDT ^VPRUTILS( X)
  11485   "RTN","VPR DJ02",50,0 )
  11486    S X=$$GET 1^DIQ(9000 011,ID_"," ,1.02,"I")
  11487   "RTN","VPR DJ02",51,0 )
  11488    S:X="P" P ROB("unver ified")="f alse",PROB ("removed" )="false"
  11489   "RTN","VPR DJ02",52,0 )
  11490    S:X="T" P ROB("unver ified")="t rue",PROB( "removed") ="false"
  11491   "RTN","VPR DJ02",53,0 )
  11492    S:X="H" P ROB("unver ified")="f alse",PROB ("removed" )="true"
  11493   "RTN","VPR DJ02",54,0 )
  11494    S X=$G(VP RL("SC")), X=$S(X="YE S":"",X="N O":"false" ,1:"")
  11495   "RTN","VPR DJ02",55,0 )
  11496    S:$L(X) P ROB("servi ceConnecte d")=X
  11497   "RTN","VPR DJ02",56,0 )
  11498    S X=$G(VP RL("PROVID ER")) I $L (X) D
  11499   "RTN","VPR DJ02",57,0 )
  11500    . S PROB( "providerN ame")=X,X= $$GET1^DIQ (9000011,I D_",",1.05 ,"I")
  11501   "RTN","VPR DJ02",58,0 )
  11502    . S PROB( "providerU id")=$$SET UID^VPRUTI LS("user", ,+X)
  11503   "RTN","VPR DJ02",59,0 )
  11504    S X=$$GET 1^DIQ(9000 011,ID_"," ,1.06) S:$ L(X) PROB( "service") =X
  11505   "RTN","VPR DJ02",60,0 )
  11506    S X=$G(VP RL("CLINIC ")) I $L(X ) D
  11507   "RTN","VPR DJ02",61,0 )
  11508    . S PROB( "locationN ame")=X
  11509   "RTN","VPR DJ02",62,0 )
  11510    . N LOC S  LOC=+$$FI ND1^DIC(44 ,,"QX",X)
  11511   "RTN","VPR DJ02",63,0 )
  11512    . S:LOC P ROB("locat ionUid")=$ $SETUID^VP RUTILS("lo cation",,L OC)
  11513   "RTN","VPR DJ02",64,0 )
  11514    S X=+$$GE T1^DIQ(900 0011,ID_", ",.06,"I")
  11515   "RTN","VPR DJ02",65,0 )
  11516    S:X FAC=$ $STA^XUAF4 (X)_U_$P($ $NS^XUAF4( X),U)
  11517   "RTN","VPR DJ02",66,0 )
  11518    I 'X S FA C=$$FAC^VP RD ;local  stn#^name
  11519   "RTN","VPR DJ02",67,0 )
  11520    D FACILIT Y^VPRUTILS (FAC,"PROB ")
  11521   "RTN","VPR DJ02",68,0 )
  11522    S I=0 F   S I=$O(VPR L("COMMENT ",I)) Q:I< 1  D
  11523   "RTN","VPR DJ02",69,0 )
  11524    . S X=$G( VPRL("COMM ENT",I))
  11525   "RTN","VPR DJ02",70,0 )
  11526    . S USER= $$VA200^VP RDGMPL($P( X,U,2)),DA TE=$$DATE^ VPRDGMPL($ P(X,U))
  11527   "RTN","VPR DJ02",71,0 )
  11528    . S PROB( "comments" ,I,"entere dByCode")= $$SETUID^V PRUTILS("u ser",,+USE R)
  11529   "RTN","VPR DJ02",72,0 )
  11530    . S PROB( "comments" ,I,"entere dByName")= $P(X,U,2)
  11531   "RTN","VPR DJ02",73,0 )
  11532    . S PROB( "comments" ,I,"entere d")=$$JSON DT^VPRUTIL S(DATE)
  11533   "RTN","VPR DJ02",74,0 )
  11534    . S PROB( "comments" ,I,"commen t")=$P(X,U ,3)
  11535   "RTN","VPR DJ02",75,0 )
  11536    D ADD^VPR DJ("PROB", "problem")
  11537   "RTN","VPR DJ02",76,0 )
  11538    Q
  11539   "RTN","VPR DJ02",77,0 )
  11540    ;
  11541   "RTN","VPR DJ02",78,0 )
  11542   GMRA1(ID)  ; -- aller gy/reactio n GMRAL(ID )
  11543   "RTN","VPR DJ02",79,0 )
  11544    N GMRA,VP RY,REAC,X, Y,I,USER,C MMT
  11545   "RTN","VPR DJ02",80,0 )
  11546    S GMRA=$G (GMRAL(ID) ) D EN1^GM RAOR2(ID," VPRY")
  11547   "RTN","VPR DJ02",81,0 )
  11548    N $ES,$ET ,ERRPAT,ER RMSG
  11549   "RTN","VPR DJ02",82,0 )
  11550    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  11551   "RTN","VPR DJ02",83,0 )
  11552    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he allergy  domain"
  11553   "RTN","VPR DJ02",84,0 )
  11554    ;
  11555   "RTN","VPR DJ02",85,0 )
  11556    S X=$P(VP RY,U,10) I  $L(X) S X =$$DATE^VP RDGMRA(X)  Q:X<VPRSTA RT  Q:X>VP RSTOP  S R EAC("enter ed")=$$JSO NDT^VPRUTI LS(X)
  11557   "RTN","VPR DJ02",86,0 )
  11558    S X=$$FAC ^VPRD D FA CILITY^VPR UTILS(X,"R EAC")
  11559   "RTN","VPR DJ02",87,0 )
  11560    S REAC("k ind")="All ergy / Adv erse React ion"
  11561   "RTN","VPR DJ02",88,0 )
  11562    S REAC("l ocalId")=I D,REAC("ui d")=$$SETU ID^VPRUTIL S("allergy ",DFN,ID)
  11563   "RTN","VPR DJ02",89,0 )
  11564    S (REAC(" summary"), REAC("prod ucts",1,"n ame"))=$P( VPRY,U) I  $P(GMRA,U, 9) D
  11565   "RTN","VPR DJ02",90,0 )
  11566    . S X=$P( GMRA,U,9), REAC("refe rence")=X
  11567   "RTN","VPR DJ02",91,0 )
  11568    . S Y=+$P (X,"(",2)  I 'Y,X["PS DRUG" S Y= 50
  11569   "RTN","VPR DJ02",92,0 )
  11570    . S I=$$V UID^VPRD(+ X,Y),REAC( "products" ,1,"vuid") =$$SETVURN ^VPRUTILS( "vuid",I)
  11571   "RTN","VPR DJ02",93,0 )
  11572    S X=$P(VP RY,U,2) S: $L(X) REAC ("originat orName")=X
  11573   "RTN","VPR DJ02",94,0 )
  11574    S REAC("h istorical" )=$S($E($P (VPRY,U,5) )="H":"tru e",1:"fals e")
  11575   "RTN","VPR DJ02",95,0 )
  11576    S X=$P(VP RY,U,6) S: $L(X) REAC ("mechanis m")=X
  11577   "RTN","VPR DJ02",96,0 )
  11578    S X=$P(VP RY,U,7) S: $L(X) REAC ("typeName ")=X
  11579   "RTN","VPR DJ02",97,0 )
  11580    ; REAC("a dverseEven tTypeName" )=$P(VPRY, U,7)_" "_$ P(VPRY,U,6 ) ;TYPE_ME CH
  11581   "RTN","VPR DJ02",98,0 )
  11582    I $P(VPRY ,U,4)="VER IFIED",$P( VPRY,U,9)  D
  11583   "RTN","VPR DJ02",99,0 )
  11584    . S REAC( "verified" )=$$JSONDT ^VPRUTILS( $P(VPRY,U, 9))
  11585   "RTN","VPR DJ02",100, 0)
  11586    . S REAC( "verifierN ame")=$P(V PRY,U,8)
  11587   "RTN","VPR DJ02",101, 0)
  11588    ; severit y
  11589   "RTN","VPR DJ02",102, 0)
  11590    S I=0 F   S I=$O(VPR Y("O",I))  Q:I<1  D
  11591   "RTN","VPR DJ02",103, 0)
  11592    . S X=$G( VPRY("O",I ))
  11593   "RTN","VPR DJ02",104, 0)
  11594    . S REAC( "observati ons",I,"da te")=$$JSO NDT^VPRUTI LS(+X)
  11595   "RTN","VPR DJ02",105, 0)
  11596    . S REAC( "observati ons",I,"se verity")=$ P(X,U,2)
  11597   "RTN","VPR DJ02",106, 0)
  11598    ; reactio ns
  11599   "RTN","VPR DJ02",107, 0)
  11600    S I=0 F   S I=$O(GMR AL(ID,"S", I)) Q:I<1   D
  11601   "RTN","VPR DJ02",108, 0)
  11602    . S X=$G( GMRAL(ID," S",I))
  11603   "RTN","VPR DJ02",109, 0)
  11604    . S REAC( "reactions ",I,"name" )=$P(X,";" )
  11605   "RTN","VPR DJ02",110, 0)
  11606    . S Y=$$V UID^VPRD(+ $P(X,";",2 ),120.83)
  11607   "RTN","VPR DJ02",111, 0)
  11608    . S REAC( "reactions ",I,"vuid" )=$$SETVUR N^VPRUTILS ("vuid",Y)
  11609   "RTN","VPR DJ02",112, 0)
  11610    ; drug cl asses
  11611   "RTN","VPR DJ02",113, 0)
  11612    S I=0 F   S I=$O(VPR Y("V",I))  Q:I<1  D
  11613   "RTN","VPR DJ02",114, 0)
  11614    . S X=$G( VPRY("V",I ))
  11615   "RTN","VPR DJ02",115, 0)
  11616    . S REAC( "drugClass es",I,"cod e")=$P(X,U )
  11617   "RTN","VPR DJ02",116, 0)
  11618    . S REAC( "drugClass es",I,"nam e")=$P(X,U ,2)
  11619   "RTN","VPR DJ02",117, 0)
  11620    S I=0 F   S I=$O(VPR Y("C",I))  Q:I<1  D
  11621   "RTN","VPR DJ02",118, 0)
  11622    . S X=$G( VPRY("C",I )),USER=$$ VA200^VPRD GMPL($P(X, U,3))
  11623   "RTN","VPR DJ02",119, 0)
  11624    . S REAC( "comments" ,I,"entere dByUid")=$ $SETUID^VP RUTILS("us er",,+USER )
  11625   "RTN","VPR DJ02",120, 0)
  11626    . S REAC( "comments" ,I,"entere dByName")= $P(X,U,3)
  11627   "RTN","VPR DJ02",121, 0)
  11628    . S REAC( "comments" ,I,"entere d")=$$JSON DT^VPRUTIL S(+X)
  11629   "RTN","VPR DJ02",122, 0)
  11630    . K CMMT  M CMMT=VPR Y("C",I)
  11631   "RTN","VPR DJ02",123, 0)
  11632    . S REAC( "comments" ,I,"commen t")=$$STRI NG^VPRD(.C MMT)
  11633   "RTN","VPR DJ02",124, 0)
  11634    I GMRA=""  S REAC("r emoved")=" true" ;ent ered in er ror
  11635   "RTN","VPR DJ02",125, 0)
  11636    D ADD^VPR DJ("REAC", "allergy")
  11637   "RTN","VPR DJ02",126, 0)
  11638    Q
  11639   "RTN","VPR DJ02",127, 0)
  11640    ;
  11641   "RTN","VPR DJ02",128, 0)
  11642   NKA ; -- n o assessme nt or NKA  [GMRAL=0 o r ""]
  11643   "RTN","VPR DJ02",129, 0)
  11644    N REAC,X
  11645   "RTN","VPR DJ02",130, 0)
  11646    S X=$G(^G MR(120.86, DFN,0)) Q: GMRAL=""!' $P(X,U,2)
  11647   "RTN","VPR DJ02",131, 0)
  11648    S REAC("u id")=$$SET UID^VPRUTI LS("obs",D FN,"120.86 ;"_DFN)
  11649   "RTN","VPR DJ02",132, 0)
  11650    S REAC("t ypeCode")= "urn:sct:1 60244002"
  11651   "RTN","VPR DJ02",133, 0)
  11652    S REAC("t ypeName")= "No known  allergies"
  11653   "RTN","VPR DJ02",134, 0)
  11654    S X=$$FAC ^VPRD D FA CILITY^VPR UTILS(X,"R EAC")
  11655   "RTN","VPR DJ02",135, 0)
  11656    D ADD^VPR DJ("REAC", "allergy")
  11657   "RTN","VPR DJ02",136, 0)
  11658    Q
  11659   "RTN","VPR DJ02",137, 0)
  11660    ;
  11661   "RTN","VPR DJ02",138, 0)
  11662   GMV1(ID) ;  -- vital/ measuremen t ^UTILITY ($J,"GMRVD ",VPRIDT,V PRTYP,ID)
  11663   "RTN","VPR DJ02",139, 0)
  11664    N VIT,VPR Y,X0,TYPE, LOC,FAC,X, Y,MRES,MUN T,HIGH,LOW ,I
  11665   "RTN","VPR DJ02",140, 0)
  11666    D GETREC^ GMVUTL(.VP RY,ID,1) S  X0=$G(VPR Y(0))
  11667   "RTN","VPR DJ02",141, 0)
  11668    ; GMRVUT0  returns C LiO data w ith a pseu do-ID >> g et real ID
  11669   "RTN","VPR DJ02",142, 0)
  11670    I X0="",$ G(VPRIDT), $D(VPRTYP)  D  ;[from  VPRDJ0]
  11671   "RTN","VPR DJ02",143, 0)
  11672    . N GMRVD  S GMRVD=$ G(^UTILITY ($J,"GMRVD ",VPRIDT,V PRTYP,ID))
  11673   "RTN","VPR DJ02",144, 0)
  11674    . S ID=$O (^PXRMINDX (120.5,"PI ",DFN,$P(G MRVD,U,3), +GMRVD,"") )
  11675   "RTN","VPR DJ02",145, 0)
  11676    . I $L(ID ) D GETREC ^GMVUTL(.V PRY,ID,1)  S X0=$G(VP RY(0))
  11677   "RTN","VPR DJ02",146, 0)
  11678    Q:X0=""
  11679   "RTN","VPR DJ02",147, 0)
  11680    ;
  11681   "RTN","VPR DJ02",148, 0)
  11682    N $ES,$ET ,ERRPAT,ER RMSG
  11683   "RTN","VPR DJ02",149, 0)
  11684    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  11685   "RTN","VPR DJ02",150, 0)
  11686    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he vitals  domain"
  11687   "RTN","VPR DJ02",151, 0)
  11688    S VIT("lo calId")=ID ,VIT("kind ")="Vital  Sign"
  11689   "RTN","VPR DJ02",152, 0)
  11690    S VIT("ui d")=$$SETU ID^VPRUTIL S("vital", DFN,ID)
  11691   "RTN","VPR DJ02",153, 0)
  11692    S VIT("ob served")=$ $JSONDT^VP RUTILS(+X0 )
  11693   "RTN","VPR DJ02",154, 0)
  11694    S VIT("re sulted")=$ $JSONDT^VP RUTILS(+$P (X0,U,4))
  11695   "RTN","VPR DJ02",155, 0)
  11696    S TYPE=$$ FIELD^GMVG ETVT(+$P(X 0,U,3),2)
  11697   "RTN","VPR DJ02",156, 0)
  11698    S VIT("di splayName" )=TYPE
  11699   "RTN","VPR DJ02",157, 0)
  11700    S VIT("ty peName")=$ $FIELD^GMV GETVT($P(X 0,U,3),1)
  11701   "RTN","VPR DJ02",158, 0)
  11702    S VIT("ty peCode")=" urn:va:vui d:"_$$FIEL D^GMVGETVT ($P(X0,U,3 ),4)
  11703   "RTN","VPR DJ02",159, 0)
  11704    S X=$P(X0 ,U,8),VIT( "result")= X
  11705   "RTN","VPR DJ02",160, 0)
  11706    S VIT("un its")=$$UN IT^VPRDGMV (TYPE),(MR ES,MUNT)=" "
  11707   "RTN","VPR DJ02",161, 0)
  11708    I TYPE="T "  S MUNT= "C",MRES=$ J(X-32*5/9 ,0,1) ;EN1 ^GMRVUTL
  11709   "RTN","VPR DJ02",162, 0)
  11710    I TYPE="H T" S MUNT= "cm",MRES= $J(2.54*X, 0,2)  ;EN2 ^GMRVUTL
  11711   "RTN","VPR DJ02",163, 0)
  11712    I TYPE="W T" S MUNT= "kg",MRES= $J(X/2.2,0 ,2)   ;EN3 ^GMRVUTL
  11713   "RTN","VPR DJ02",164, 0)
  11714    I TYPE="C G" S MUNT= "cm",MRES= $J(2.54*X, 0,2)
  11715   "RTN","VPR DJ02",165, 0)
  11716    S:MRES VI T("metricR esult")=MR ES,VIT("me tricUnits" )=MUNT
  11717   "RTN","VPR DJ02",166, 0)
  11718    S X=$$RAN GE^VPRDGMV (TYPE) I $ L(X) S VIT ("high")=$ P(X,U),VIT ("low")=$P (X,U,2)
  11719   "RTN","VPR DJ02",167, 0)
  11720    S VIT("su mmary")=VI T("typeNam e")_" "_VI T("result" )_" "_VIT( "units")
  11721   "RTN","VPR DJ02",168, 0)
  11722    F I=1:1:$ L(VPRY(5), U) S X=$P( VPRY(5),U, I) I X D
  11723   "RTN","VPR DJ02",169, 0)
  11724    . S VIT(" qualifiers ",I,"name" )=$$FIELD^ GMVGETQL(X ,1)
  11725   "RTN","VPR DJ02",170, 0)
  11726    . S VIT(" qualifiers ",I,"vuid" )=$$FIELD^ GMVGETQL(X ,3)
  11727   "RTN","VPR DJ02",171, 0)
  11728    I $G(VPRY (2)) S VIT ("removed" )="true"         ;ent ered in er ror
  11729   "RTN","VPR DJ02",172, 0)
  11730    S LOC=+$P (X0,U,5),F AC=$$FAC^V PRD(LOC)
  11731   "RTN","VPR DJ02",173, 0)
  11732    S VIT("lo cationUid" )=$$SETUID ^VPRUTILS( "location" ,,LOC)
  11733   "RTN","VPR DJ02",174, 0)
  11734    S VIT("lo cationName ")=$S(LOC: $P($G(^SC( LOC,0)),U) ,1:"unknow n")
  11735   "RTN","VPR DJ02",175, 0)
  11736    D FACILIT Y^VPRUTILS (FAC,"VIT" )
  11737   "RTN","VPR DJ02",176, 0)
  11738    D ADD^VPR DJ("VIT"," vital")
  11739   "RTN","VPR DJ02",177, 0)
  11740    Q
  11741   "RTN","VPR DJ02",178, 0)
  11742    ;
  11743   "RTN","VPR DJ02",179, 0)
  11744   VPR(COLL)  ; -- VPR P atient Obj ects
  11745   "RTN","VPR DJ02",180, 0)
  11746    N ID I $L ($G(VPRID) ) D  Q
  11747   "RTN","VPR DJ02",181, 0)
  11748    . S ID=+V PRID I 'ID  S ID=+$O( ^VPR(560.1 ,"B",VPRID ,0)) ;IEN  or UID
  11749   "RTN","VPR DJ02",182, 0)
  11750    . D:ID VP R1(560.1,I D)
  11751   "RTN","VPR DJ02",183, 0)
  11752    Q:$G(COLL )=""  ;err or
  11753   "RTN","VPR DJ02",184, 0)
  11754    S ID=0 F   S ID=$O(^ VPR(560.1, "C",DFN,CO LL,ID)) Q: ID<1  D VP R1(560.1,I D)
  11755   "RTN","VPR DJ02",185, 0)
  11756    Q
  11757   "RTN","VPR DJ02",186, 0)
  11758   VPR1(FNUM, ID) ; -- [ patient] o bject
  11759   "RTN","VPR DJ02",187, 0)
  11760    N I,X,VPR Y
  11761   "RTN","VPR DJ02",188, 0)
  11762    N $ES,$ET ,ERRPAT,ER RMSG
  11763   "RTN","VPR DJ02",189, 0)
  11764    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=$G(DF N)
  11765   "RTN","VPR DJ02",190, 0)
  11766    S ERRMSG= "A problem  occurred  retreiving  record "_ ID_" for t he VPR dom ain"
  11767   "RTN","VPR DJ02",191, 0)
  11768    S I=0 F   S I=$O(^VP R(FNUM,ID, 1,I)) Q:I< 1  S X=$G( ^(I,0)),VP RY(I)=X
  11769   "RTN","VPR DJ02",192, 0)
  11770    I $D(VPRY ) D  ;alre ady encode d JSON
  11771   "RTN","VPR DJ02",193, 0)
  11772    . S VPRI= VPRI+1 S:V PRI>1 @VPR @(VPRI,.3) =","
  11773   "RTN","VPR DJ02",194, 0)
  11774    . M @VPR@ (VPRI)=VPR Y
  11775   "RTN","VPR DJ02",195, 0)
  11776    Q
  11777   "RTN","VPR DJ03")
  11778   0^73^B5434 6353
  11779   "RTN","VPR DJ03",1,0)
  11780   VPRDJ03 ;S LC/MKB --  Consults,C linProcedu res,CLiO ; 6/25/12  1 6:11
  11781   "RTN","VPR DJ03",2,0)
  11782    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  11783   "RTN","VPR DJ03",3,0)
  11784    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  11785   "RTN","VPR DJ03",4,0)
  11786    ;
  11787   "RTN","VPR DJ03",5,0)
  11788    ; Externa l Referenc es           DBIA#
  11789   "RTN","VPR DJ03",6,0)
  11790    ; ------- ---------- --           -----
  11791   "RTN","VPR DJ03",7,0)
  11792    ; ^SC                             10040
  11793   "RTN","VPR DJ03",8,0)
  11794    ; ^TIU(89 25.1                     5677
  11795   "RTN","VPR DJ03",9,0)
  11796    ; ^VA(200                         10060
  11797   "RTN","VPR DJ03",10,0 )
  11798    ; %DT                             10003
  11799   "RTN","VPR DJ03",11,0 )
  11800    ; DILFD                            2055
  11801   "RTN","VPR DJ03",12,0 )
  11802    ; DIQ                              2056
  11803   "RTN","VPR DJ03",13,0 )
  11804    ; GMRCGUI B                        2980
  11805   "RTN","VPR DJ03",14,0 )
  11806    ; GMRCSLM 1,^TMP("GM RCR"          2740
  11807   "RTN","VPR DJ03",15,0 )
  11808    ; MCARUTL 3                        3280
  11809   "RTN","VPR DJ03",16,0 )
  11810    ; MDPS1,^ TMP("MDHSP "             4230
  11811   "RTN","VPR DJ03",17,0 )
  11812    ; ORX8                             2467
  11813   "RTN","VPR DJ03",18,0 )
  11814    ; TIULQ                            2693
  11815   "RTN","VPR DJ03",19,0 )
  11816    ; TIUSRVL O                        2834
  11817   "RTN","VPR DJ03",20,0 )
  11818    ; XLFSTR                          10104
  11819   "RTN","VPR DJ03",21,0 )
  11820    ; XUAF4                            2171
  11821   "RTN","VPR DJ03",22,0 )
  11822    ;
  11823   "RTN","VPR DJ03",23,0 )
  11824    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  11825   "RTN","VPR DJ03",24,0 )
  11826    ;
  11827   "RTN","VPR DJ03",25,0 )
  11828   GMRC1(ID)  ; -- consu lt/request  VPRX=^TMP ("GMRCR",$ J,"CS",VPR N,0)
  11829   "RTN","VPR DJ03",26,0 )
  11830    N CONS,OR DER,VPRD,X 0,X,VPRJ,V PRTIU
  11831   "RTN","VPR DJ03",27,0 )
  11832    N $ES,$ET ,ERRPAT,ER RMSG
  11833   "RTN","VPR DJ03",28,0 )
  11834    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  11835   "RTN","VPR DJ03",29,0 )
  11836    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he consult s domain"
  11837   "RTN","VPR DJ03",30,0 )
  11838    ;
  11839   "RTN","VPR DJ03",31,0 )
  11840    S CONS("l ocalId")=+ VPRX,CONS( "uid")=$$S ETUID^VPRU TILS("cons ult",DFN,+ VPRX)
  11841   "RTN","VPR DJ03",32,0 )
  11842    S CONS("d ateTime")= $$JSONDT^V PRUTILS($P (VPRX,U,2) )
  11843   "RTN","VPR DJ03",33,0 )
  11844    S CONS("s tatusName" )=$P(VPRX, U,3),CONS( "service") =$P(VPRX,U ,4)
  11845   "RTN","VPR DJ03",34,0 )
  11846    S CONS("c onsultProc edure")=$P (VPRX,U,5)
  11847   "RTN","VPR DJ03",35,0 )
  11848    I $P(VPRX ,U,6)="*"  S CONS("in terpretati on")="SIGN IFICANT FI NDINGS"
  11849   "RTN","VPR DJ03",36,0 )
  11850    S CONS("t ypeName")= $P(VPRX,U, 7),CONS("c ategory")= $P(VPRX,U, 9)
  11851   "RTN","VPR DJ03",37,0 )
  11852    S ORDER=+ $P(VPRX,U, 8),CONS("o rderName") =$P($$OI^O RX8(ORDER) ,U,2)
  11853   "RTN","VPR DJ03",38,0 )
  11854    S CONS("o rderUid")= $$SETUID^V PRUTILS("o rder",DFN, ORDER)
  11855   "RTN","VPR DJ03",39,0 )
  11856    D DOCLIST ^GMRCGUIB( .VPRD,+VPR X) S X0=$G (VPRD(0))  ;=^GMR(123 ,ID,0)
  11857   "RTN","VPR DJ03",40,0 )
  11858    S X=+$P(X 0,U,14) I  X D  ;orde ring provi der
  11859   "RTN","VPR DJ03",41,0 )
  11860    . S CONS( "providerU id")=$$SET UID^VPRUTI LS("user", ,X)
  11861   "RTN","VPR DJ03",42,0 )
  11862    . S CONS( "providerN ame")=$P($ G(^VA(200, X,0)),U)
  11863   "RTN","VPR DJ03",43,0 )
  11864    S VPRJ=0  F  S VPRJ= $O(VPRD(50 ,VPRJ)) Q: VPRJ<1  S  X=$G(VPRD( 50,VPRJ))  D
  11865   "RTN","VPR DJ03",44,0 )
  11866    . Q:'$D(@ (U_$P(X,"; ",2)_+X_") "))  ;text  deleted
  11867   "RTN","VPR DJ03",45,0 )
  11868    . S CONS( "results", VPRJ,"uid" )=$$SETUID ^VPRUTILS( "document" ,DFN,+X)
  11869   "RTN","VPR DJ03",46,0 )
  11870    . D EXTRA CT^TIULQ(+ X,"VPRTIU" ,,.01)
  11871   "RTN","VPR DJ03",47,0 )
  11872    . S CONS( "results", VPRJ,"loca lTitle")=$ G(VPRTIU(+ X,.01,"E") )
  11873   "RTN","VPR DJ03",48,0 )
  11874    S X=$P(X0 ,U,21),X=$ S(X:$$STA^ XUAF4(X)_U _$P($$NS^X UAF4(X),U) ,1:$$FAC^V PRD)
  11875   "RTN","VPR DJ03",49,0 )
  11876    D FACILIT Y^VPRUTILS (X,"CONS")
  11877   "RTN","VPR DJ03",50,0 )
  11878    D ADD^VPR DJ("CONS", "consult")
  11879   "RTN","VPR DJ03",51,0 )
  11880    Q
  11881   "RTN","VPR DJ03",52,0 )
  11882    ;
  11883   "RTN","VPR DJ03",53,0 )
  11884   MDPS1(DFN, BEG,END,MA X) ; -- pe rform CP s earch (sco pe variabl es)
  11885   "RTN","VPR DJ03",54,0 )
  11886    N MCARCOD E,MCARDT,M CARPROC,MC ESKEY,MCES SEC,MCFILE ,MDC,MDIMG ,RES
  11887   "RTN","VPR DJ03",55,0 )
  11888    S BEG=$G( BEG,141010 1),END=$G( END,414101 5),MAX=$G( MAX,9999)
  11889   "RTN","VPR DJ03",56,0 )
  11890    K ^TMP("M DHSP",$J)  S RES=""
  11891   "RTN","VPR DJ03",57,0 )
  11892    D EN1^MDP S1(.RES,DF N,BEG,END, MAX,"",0)  ;RES=^TMP( "MDHSP",$J )
  11893   "RTN","VPR DJ03",58,0 )
  11894    Q
  11895   "RTN","VPR DJ03",59,0 )
  11896    ;
  11897   "RTN","VPR DJ03",60,0 )
  11898   MC1(ID) ;  -- clinica l procedur e VPRX=^TM P("MDHSP", $J,VPRN)
  11899   "RTN","VPR DJ03",61,0 )
  11900    N X,Y,%DT ,DATE,RTN, GBL,CONS,T IUN,VPRD,X 0,PROC,VPR T,LOC,FAC
  11901   "RTN","VPR DJ03",62,0 )
  11902    N $ES,$ET ,ERRPAT,ER RMSG
  11903   "RTN","VPR DJ03",63,0 )
  11904    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  11905   "RTN","VPR DJ03",64,0 )
  11906    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he clinica l procedur e domain"
  11907   "RTN","VPR DJ03",65,0 )
  11908    ;
  11909   "RTN","VPR DJ03",66,0 )
  11910    S RTN=$P( VPRX,U,3,4 ) Q:RTN="P RPRO^MDPS4 "  ;skip n on-CP item s
  11911   "RTN","VPR DJ03",67,0 )
  11912    S X=$P(VP RX,U,6),%D T="TXS" D  ^%DT Q:Y'> 0  S DATE= Y
  11913   "RTN","VPR DJ03",68,0 )
  11914    S GBL=+$P (VPRX,U,2) _";"_$S(RT N="PR702^M DPS1":"MDD (702,",1:$ $ROOT^VPRD MC(DFN,$P( VPRX,U,11) ,DATE))
  11915   "RTN","VPR DJ03",69,0 )
  11916    Q:'GBL  I  $G(ID),ID '=GBL Q                  ;unknow n, or not  requested
  11917   "RTN","VPR DJ03",70,0 )
  11918    ;
  11919   "RTN","VPR DJ03",71,0 )
  11920    S CONS=+$ P(VPRX,U,1 3) D:CONS  DOCLIST^GM RCGUIB(.VP RD,CONS) S  X0=$G(VPR D(0)) ;=^G MR(123,ID, 0)
  11921   "RTN","VPR DJ03",72,0 )
  11922    S TIUN=+$ P(VPRX,U,1 4) S:TIUN  TIUN=TIUN_ U_$$RESOLV E^TIUSRVLO (TIUN)
  11923   "RTN","VPR DJ03",73,0 )
  11924    S PROC("l ocalId")=G BL,PROC("c ategory")= "CP"
  11925   "RTN","VPR DJ03",74,0 )
  11926    S PROC("u id")=$$SET UID^VPRUTI LS("proced ure",DFN,G BL)
  11927   "RTN","VPR DJ03",75,0 )
  11928    S PROC("n ame")=$P(V PRX,U),PRO C("dateTim e")=$$JSON DT^VPRUTIL S(DATE)
  11929   "RTN","VPR DJ03",76,0 )
  11930    S X=$P(VP RX,U,7) S: $L(X) PROC ("interpre tation")=X
  11931   "RTN","VPR DJ03",77,0 )
  11932    S PROC("k ind")="Pro cedure"
  11933   "RTN","VPR DJ03",78,0 )
  11934    I CONS,X0  D
  11935   "RTN","VPR DJ03",79,0 )
  11936    . N VPRJ  S PROC("re quested")= $$JSONDT^V PRUTILS(+X 0)
  11937   "RTN","VPR DJ03",80,0 )
  11938    . S PROC( "consultUi d")=$$SETU ID^VPRUTIL S("consult ",DFN,CONS )
  11939   "RTN","VPR DJ03",81,0 )
  11940    . S PROC( "orderUid" )=$$SETUID ^VPRUTILS( "order",DF N,+$P(X0,U ,3))
  11941   "RTN","VPR DJ03",82,0 )
  11942    . S PROC( "statusNam e")=$$EXTE RNAL^DILFD (123,8,,$P (X0,U,12))
  11943   "RTN","VPR DJ03",83,0 )
  11944    . S VPRJ= 0 F  S VPR J=$O(VPRD( 50,VPRJ))  Q:VPRJ<1   S X=+$G(VP RD(50,VPRJ )) D
  11945   "RTN","VPR DJ03",84,0 )
  11946    .. D NOTE (X)
  11947   "RTN","VPR DJ03",85,0 )
  11948    .. S:'TIU N TIUN=X_U _$$RESOLVE ^TIUSRVLO( X)
  11949   "RTN","VPR DJ03",86,0 )
  11950    I TIUN D
  11951   "RTN","VPR DJ03",87,0 )
  11952    . S X=$P( TIUN,U,5)  I X D
  11953   "RTN","VPR DJ03",88,0 )
  11954    .. S PROC ("provider s",1,"prov iderUid")= $$SETUID^V PRUTILS("u ser",,+X)
  11955   "RTN","VPR DJ03",89,0 )
  11956    .. S PROC ("provider s",1,"prov iderName") =$P(X,";", 3)
  11957   "RTN","VPR DJ03",90,0 )
  11958    . S:$P(TI UN,U,11) P ROC("hasIm ages")="tr ue"
  11959   "RTN","VPR DJ03",91,0 )
  11960    . K VPRT  D EXTRACT^ TIULQ(+TIU N,"VPRT",, ".03;.05;1 211",,,"I" )
  11961   "RTN","VPR DJ03",92,0 )
  11962    . S X=+$G (VPRT(+TIU N,.03,"I") ),PROC("en counterUid ")=$$SETUI D^VPRUTILS ("visit",D FN,X)
  11963   "RTN","VPR DJ03",93,0 )
  11964    . S LOC=+ $G(VPRT(+T IUN,1211," I")) I LOC  S LOC=LOC _U_$P($G(^ SC(LOC,0)) ,U)
  11965   "RTN","VPR DJ03",94,0 )
  11966    . E  S X= $P(TIUN,U, 6) S:$L(X)  LOC=+$O(^ SC("B",X,0 ))_U_X
  11967   "RTN","VPR DJ03",95,0 )
  11968    . S:LOC P ROC("locat ionUid")=$ $SETUID^VP RUTILS("lo cation",,+ LOC),PROC( "locationN ame")=$P(L OC,U,2),FA C=$$FAC^VP RD(+LOC)
  11969   "RTN","VPR DJ03",96,0 )
  11970    . I '$D(P ROC("statu sName")) S  X=+$G(VPR T(+TIUN,.0 5,"I")),PR OC("status Name")=$S( X<6:"PARTI AL RESULTS ",1:"COMPL ETE")
  11971   "RTN","VPR DJ03",97,0 )
  11972    . I '$G(P ROC("resul ts",+TIUN) ) D NOTE(+ TIUN)
  11973   "RTN","VPR DJ03",98,0 )
  11974    ; if no c onsult or  note/visit  ...
  11975   "RTN","VPR DJ03",99,0 )
  11976    S:'$D(PRO C("statusN ame")) PRO C("statusN ame")="COM PLETE"
  11977   "RTN","VPR DJ03",100, 0)
  11978    I '$D(FAC ) S X=$P(X 0,U,21),FA C=$S(X:$$S TA^XUAF4(X )_U_$P($$N S^XUAF4(X) ,U),1:$$FA C^VPRD)
  11979   "RTN","VPR DJ03",101, 0)
  11980    D FACILIT Y^VPRUTILS (FAC,"PROC ")
  11981   "RTN","VPR DJ03",102, 0)
  11982    D ADD^VPR DJ("PROC", "procedure ")
  11983   "RTN","VPR DJ03",103, 0)
  11984    Q
  11985   "RTN","VPR DJ03",104, 0)
  11986    ;
  11987   "RTN","VPR DJ03",105, 0)
  11988   NOTE(DA) ;  -- add TI U note inf o
  11989   "RTN","VPR DJ03",106, 0)
  11990    N VPRT,TE XT
  11991   "RTN","VPR DJ03",107, 0)
  11992    D EXTRACT ^TIULQ(DA, "VPRT",,.0 1)
  11993   "RTN","VPR DJ03",108, 0)
  11994    S PROC("r esults",DA ,"uid")=$$ SETUID^VPR UTILS("doc ument",+$G (DFN),DA)
  11995   "RTN","VPR DJ03",109, 0)
  11996    S PROC("r esults",DA ,"localTit le")=$G(VP RT(DA,.01, "E"))
  11997   "RTN","VPR DJ03",110, 0)
  11998    Q
  11999   "RTN","VPR DJ03",111, 0)
  12000    ;
  12001   "RTN","VPR DJ03",112, 0)
  12002   MDC1(ID) ;  -- clinic al observa tion
  12003   "RTN","VPR DJ03",113, 0)
  12004    N GUID,CL IO,VPRC,VP RT,LOC,FAC ,I,X,Y
  12005   "RTN","VPR DJ03",114, 0)
  12006    S GUID=$G (ID) Q:GUI D=""  ;inv alid GUID
  12007   "RTN","VPR DJ03",115, 0)
  12008    D QRYOBS^ VPRDMDC("V PRC",GUID)  Q:'$D(VPR C)  ;doesn 't exist
  12009   "RTN","VPR DJ03",116, 0)
  12010    Q:$L($G(V PRC("PAREN T_ID","E") ))             ;PAREN T also in  list
  12011   "RTN","VPR DJ03",117, 0)
  12012    N $ES,$ET ,ERRPAT,ER RMSG
  12013   "RTN","VPR DJ03",118, 0)
  12014    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  12015   "RTN","VPR DJ03",119, 0)
  12016    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he clinica l observat ion domain "
  12017   "RTN","VPR DJ03",120, 0)
  12018    ;
  12019   "RTN","VPR DJ03",121, 0)
  12020    S CLIO("l ocalId")=G UID,CLIO(" uid")=$$SE TUID^VPRUT ILS("obs", DFN,GUID)
  12021   "RTN","VPR DJ03",122, 0)
  12022    S X=$G(VP RC("TERM_I D","I")) S :X CLIO("t ypeVuid")= "urn:va:vu id:"_X
  12023   "RTN","VPR DJ03",123, 0)
  12024    S CLIO("t ypeCode")= "urn:va:cl ioterminol ogy:"_$G(V PRC("TERM_ ID","GUID" ))
  12025   "RTN","VPR DJ03",124, 0)
  12026    S CLIO("t ypeName")= $G(VPRC("T ERM_ID","E "))
  12027   "RTN","VPR DJ03",125, 0)
  12028    S CLIO("r esult")=$G (VPRC("SVA LUE","E"))
  12029   "RTN","VPR DJ03",126, 0)
  12030    S X=$G(VP RC("UNIT_I D","ABBV") ) S:$L(X)  CLIO("unit s")=X
  12031   "RTN","VPR DJ03",127, 0)
  12032    S X=$G(VP RC("ENTERE D_DATE_TIM E","I")),C LIO("enter ed")=$$JSO NDT^VPRUTI LS(X)
  12033   "RTN","VPR DJ03",128, 0)
  12034    S X=$G(VP RC("OBSERV ED_DATE_TI ME","I")), CLIO("obse rved")=$$J SONDT^VPRU TILS(X)
  12035   "RTN","VPR DJ03",129, 0)
  12036    D QRYTYPE S^VPRDMDC( "VPRT")
  12037   "RTN","VPR DJ03",130, 0)
  12038    F I=3,5 S  X=$G(VPRT (I,"XML"))  I $L($G(V PRC(X,"E") )) D
  12039   "RTN","VPR DJ03",131, 0)
  12040    . S Y=VPR T(I,"NAME" ),Y=$S(Y=" LOCATION": "bodySite" ,1:$$LOW^X LFSTR(Y))
  12041   "RTN","VPR DJ03",132, 0)
  12042    . S CLIO( Y_"Code")= VPRC(X,"I" ),CLIO(Y_" Name")=VPR C(X,"E")
  12043   "RTN","VPR DJ03",133, 0)
  12044    F I=4,6,7  S X=$G(VP RT(I,"XML" )) I $L($G (VPRC(X,"E "))) D
  12045   "RTN","VPR DJ03",134, 0)
  12046    . S CLIO( "qualifier s",I,"type ")=$$LOW^X LFSTR(VPRT (I,"NAME") )
  12047   "RTN","VPR DJ03",135, 0)
  12048    . S CLIO( "qualifier s",I,"code ")=VPRC(X, "I")
  12049   "RTN","VPR DJ03",136, 0)
  12050    . S CLIO( "qualifier s",I,"name ")=VPRC(X, "E")
  12051   "RTN","VPR DJ03",137, 0)
  12052    S X=$G(VP RC("RANGE" ,"E")) I $ L(X) D
  12053   "RTN","VPR DJ03",138, 0)
  12054    . S Y=$S( X="Out of  Bounds Low ":"<",X="O ut of Boun ds High":" >",1:$E(X) )
  12055   "RTN","VPR DJ03",139, 0)
  12056    . S CLIO( "interpret ationCode" )="urn:hl7 :observati on-interpr etation:"_ Y
  12057   "RTN","VPR DJ03",140, 0)
  12058    . S CLIO( "interpret ationName" )=$S(X="<" :"Low off  scale",X=" >":"High o ff scale", 1:X)
  12059   "RTN","VPR DJ03",141, 0)
  12060    ; X=$G(VP RC("STATUS ","E")) S: $L(X) CLIO ("resultSt atus")=$S( X="unverif ied":"acti ve",1:"com plete")
  12061   "RTN","VPR DJ03",142, 0)
  12062    I $D(VPRC ("SUPP_PAG E")) D  ;a dd set inf o
  12063   "RTN","VPR DJ03",143, 0)
  12064    . S CLIO( "setID")=$ G(VPRC("SU PP_PAGE"," GUID"))
  12065   "RTN","VPR DJ03",144, 0)
  12066    . S CLIO( "setName") =$G(VPRC(" SUPP_PAGE" ,"DISPLAY_ NAME"))
  12067   "RTN","VPR DJ03",145, 0)
  12068    . S X=$G( VPRC("SUPP _PAGE","TY PE")) S:$L (X) CLIO(" setType")= X
  12069   "RTN","VPR DJ03",146, 0)
  12070    . S X=$G( VPRC("SUPP _PAGE","AC TIVATED_DA TE_TIME"))  S:X CLIO( "setStart" )=$$JSONDT ^VPRUTILS( X)
  12071   "RTN","VPR DJ03",147, 0)
  12072    . S X=$G( VPRC("SUPP _PAGE","DE ACTIVATED_ DATE_TIME" )) S:X CLI O("setStop ")=$$JSOND T^VPRUTILS (X)
  12073   "RTN","VPR DJ03",148, 0)
  12074    S CLIO("s tatusCode" )="urn:va: observatio n-status:c omplete",C LIO("statu sName")="c omplete"
  12075   "RTN","VPR DJ03",149, 0)
  12076    S LOC=$G( VPRC("HOSP ITAL_LOCAT ION_ID","I ")),FAC=$$ FAC^VPRD(L OC)
  12077   "RTN","VPR DJ03",150, 0)
  12078    S CLIO("l ocationUid ")=$$SETUI D^VPRUTILS ("location ",,LOC)
  12079   "RTN","VPR DJ03",151, 0)
  12080    S CLIO("l ocationNam e")=$G(VPR C("HOSPITA L_LOCATION _ID","E"))
  12081   "RTN","VPR DJ03",152, 0)
  12082    D FACILIT Y^VPRUTILS (FAC,"CLIO ")
  12083   "RTN","VPR DJ03",153, 0)
  12084    S X=$G(VP RC("COMMEN T","E")) S :$L(X) CLI O("comment ")=X
  12085   "RTN","VPR DJ03",154, 0)
  12086    D ADD^VPR DJ("CLIO", "obs")
  12087   "RTN","VPR DJ03",155, 0)
  12088    Q
  12089   "RTN","VPR DJ04")
  12090   0^74^B4830 0621
  12091   "RTN","VPR DJ04",1,0)
  12092   VPRDJ04 ;S LC/MKB --  Appointmen ts,Visits  ;6/25/12   16:11
  12093   "RTN","VPR DJ04",2,0)
  12094    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  12095   "RTN","VPR DJ04",3,0)
  12096    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  12097   "RTN","VPR DJ04",4,0)
  12098    ;
  12099   "RTN","VPR DJ04",5,0)
  12100    ; Externa l Referenc es           DBIA#
  12101   "RTN","VPR DJ04",6,0)
  12102    ; ------- ---------- --           -----
  12103   "RTN","VPR DJ04",7,0)
  12104    ; ^AUPNVS IT                       2028
  12105   "RTN","VPR DJ04",8,0)
  12106    ; ^DGS(41 .1                       3796
  12107   "RTN","VPR DJ04",9,0)
  12108    ; ^DIC(42                         10039
  12109   "RTN","VPR DJ04",10,0 )
  12110    ; ^SC                             10040
  12111   "RTN","VPR DJ04",11,0 )
  12112    ; ^VA(200                         10060
  12113   "RTN","VPR DJ04",12,0 )
  12114    ; DIQ                              2056
  12115   "RTN","VPR DJ04",13,0 )
  12116    ; ICPTCOD                          1995
  12117   "RTN","VPR DJ04",14,0 )
  12118    ; PXAPI,^ TMP("PXKEN C"            1894
  12119   "RTN","VPR DJ04",15,0 )
  12120    ; SDAMA30 1                        4433
  12121   "RTN","VPR DJ04",16,0 )
  12122    ; XLFDT                           10103
  12123   "RTN","VPR DJ04",17,0 )
  12124    ; XUAF4                            2171
  12125   "RTN","VPR DJ04",18,0 )
  12126    ;
  12127   "RTN","VPR DJ04",19,0 )
  12128    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  12129   "RTN","VPR DJ04",20,0 )
  12130    ;
  12131   "RTN","VPR DJ04",21,0 )
  12132   SDAM1 ; --  appointme nt ^TMP($J ,"SDAMA301 ",DFN,VPRD T)
  12133   "RTN","VPR DJ04",22,0 )
  12134    N NODE,HL OC,APPT,X, STS,CLS,FA C,SV,PRV
  12135   "RTN","VPR DJ04",23,0 )
  12136    S NODE=$G (^TMP($J," SDAMA301", DFN,VPRDT) )
  12137   "RTN","VPR DJ04",24,0 )
  12138    N $ES,$ET ,ERRPAT,ER RMSG
  12139   "RTN","VPR DJ04",25,0 )
  12140    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  12141   "RTN","VPR DJ04",26,0 )
  12142    S ERRMSG= "A problem  occurred  converting  a record  for the ap pointment  domain"
  12143   "RTN","VPR DJ04",27,0 )
  12144    ;
  12145   "RTN","VPR DJ04",28,0 )
  12146    S HLOC=$P (NODE,U,2) ,X="A;"_VP RDT_";"_+H LOC
  12147   "RTN","VPR DJ04",29,0 )
  12148    I $L($G(I D)),$P(ID, ";",1,3)'= X Q
  12149   "RTN","VPR DJ04",30,0 )
  12150    S APPT("l ocalId")=X ,APPT("uid ")=$$SETUI D^VPRUTILS ("appointm ent",DFN,X )
  12151   "RTN","VPR DJ04",31,0 )
  12152    S X=$P(NO DE,U,10),A PPT("typeC ode")=$P(X ,";"),APPT ("typeName ")=$P(X,"; ",2)
  12153   "RTN","VPR DJ04",32,0 )
  12154    S STS=$P( NODE,U,3), CLS=$S($E( STS)="I":" I",1:"O")
  12155   "RTN","VPR DJ04",33,0 )
  12156    S APPT("d ateTime")= $$JSONDT^V PRUTILS(VP RDT)
  12157   "RTN","VPR DJ04",34,0 )
  12158    S:$L($P(N ODE,U,6))  APPT("comm ent")=$P(N ODE,U,6)
  12159   "RTN","VPR DJ04",35,0 )
  12160    S:$P(NODE ,U,9) APPT ("checkIn" )=$$JSONDT ^VPRUTILS( $P(NODE,U, 9))
  12161   "RTN","VPR DJ04",36,0 )
  12162    S:$P(NODE ,U,11) APP T("checkOu t")=$$JSON DT^VPRUTIL S($P(NODE, U,11))
  12163   "RTN","VPR DJ04",37,0 )
  12164    I $L(ID," ;")>3 S AP PT("reason Name")=$P( ID,";",4), PRV=+$P(ID ,";",5) ;f rom SDAM e vent
  12165   "RTN","VPR DJ04",38,0 )
  12166    S FAC=$$F AC^VPRD(+H LOC) D FAC ILITY^VPRU TILS(FAC," APPT") I H LOC D
  12167   "RTN","VPR DJ04",39,0 )
  12168    . S APPT( "locationN ame")=$P(H LOC,";",2)
  12169   "RTN","VPR DJ04",40,0 )
  12170    . S APPT( "locationU id")=$$SET UID^VPRUTI LS("locati on",,+HLOC )
  12171   "RTN","VPR DJ04",41,0 )
  12172    . S X=$$A MIS^VPRDVS IT(+$P(NOD E,U,13))
  12173   "RTN","VPR DJ04",42,0 )
  12174    . S:$L(X)  APPT("sto pCodeUid") ="urn:va:s top-code:" _$P(X,U),A PPT("stopC odeName")= $P(X,U,2)
  12175   "RTN","VPR DJ04",43,0 )
  12176    . S SV=$$ GET1^DIQ(4 4,+HLOC_", ",9.5,"I")
  12177   "RTN","VPR DJ04",44,0 )
  12178    . I SV S  APPT("serv ice")=$$SE RV^VPRDSDA M(SV)
  12179   "RTN","VPR DJ04",45,0 )
  12180    . ;find d efault pro vider
  12181   "RTN","VPR DJ04",46,0 )
  12182    . S:'$G(P RV) PRV=+$ $GET1^DIQ( 44,+HLOC_" ,",16,"I")  I 'PRV D
  12183   "RTN","VPR DJ04",47,0 )
  12184    .. N VPRP ,I,FIRST
  12185   "RTN","VPR DJ04",48,0 )
  12186    .. D GETS ^DIQ(44,+H LOC_",","2 600*","I", "VPRP")
  12187   "RTN","VPR DJ04",49,0 )
  12188    .. S FIRS T=$O(VPRP( 44.1,"")), I=""
  12189   "RTN","VPR DJ04",50,0 )
  12190    .. F  S I =$O(VPRP(4 4.1,I)) Q: I=""  I $G (VPRP(44.1 ,I,.02,"I" )) S PRV=$ G(VPRP(44. 1,I,.01,"I ")) Q
  12191   "RTN","VPR DJ04",51,0 )
  12192    .. I 'PRV ,FIRST S P RV=$G(VPRP (44.1,FIRS T,.01,"I") )
  12193   "RTN","VPR DJ04",52,0 )
  12194    I $G(PRV)  S APPT("p roviders", 1,"provide rUid")=$$S ETUID^VPRU TILS("user ",,PRV),AP PT("provid ers",1,"pr oviderName ")=$P($G(^ VA(200,PRV ,0)),U)
  12195   "RTN","VPR DJ04",53,0 )
  12196    S APPT("p atientClas sCode")="u rn:va:pati ent-class: "_$S(CLS=" I":"IMP",1 :"AMB")
  12197   "RTN","VPR DJ04",54,0 )
  12198    S APPT("p atientClas sName")=$S (CLS="I":" Inpatient" ,1:"Ambula tory")
  12199   "RTN","VPR DJ04",55,0 )
  12200    S APPT("c ategoryCod e")="urn:v a:encounte r-category :OV",APPT( "categoryN ame")="Out patient Vi sit"
  12201   "RTN","VPR DJ04",56,0 )
  12202    S APPT("a ppointment Status")=$ P(STS,";", 2)
  12203   "RTN","VPR DJ04",57,0 )
  12204    D ADD^VPR DJ("APPT", "appointme nt")
  12205   "RTN","VPR DJ04",58,0 )
  12206    Q
  12207   "RTN","VPR DJ04",59,0 )
  12208    ;
  12209   "RTN","VPR DJ04",60,0 )
  12210   DGS ; sche duled admi ssions [fr om APPOINT M^VPRDJ0]
  12211   "RTN","VPR DJ04",61,0 )
  12212    S VPRA=0  F  S VPRA= $O(^DGS(41 .1,"B",DFN ,VPRA)) Q: VPRA<1  D   Q:VPRI'<V PRMAX
  12213   "RTN","VPR DJ04",62,0 )
  12214    . S VPRX= $G(^DGS(41 .1,VPRA,0) )
  12215   "RTN","VPR DJ04",63,0 )
  12216    . I $L($G (ID)),+$P( ID,";",2)= +$P(VPRX,U ,2) D DGS1 (VPRA) Q
  12217   "RTN","VPR DJ04",64,0 )
  12218    . Q:$P(VP RX,U,13)   Q:$P(VPRX, U,17)  ;ca ncelled or  admitted
  12219   "RTN","VPR DJ04",65,0 )
  12220    . S X=$P( VPRX,U,2)  Q:X<VPRSTA RT!(X>VPRS TOP)  ;out  of date r ange
  12221   "RTN","VPR DJ04",66,0 )
  12222    . D DGS1( VPRA)
  12223   "RTN","VPR DJ04",67,0 )
  12224    Q
  12225   "RTN","VPR DJ04",68,0 )
  12226    ;
  12227   "RTN","VPR DJ04",69,0 )
  12228   DGS1(IFN)  ; -- sched uled admis sion
  12229   "RTN","VPR DJ04",70,0 )
  12230    N ADM,X0, DATE,HLOC, FAC,SV,X
  12231   "RTN","VPR DJ04",71,0 )
  12232    S X0=$G(^ DGS(41.1,+ $G(IFN),0) ) Q:X0=""   ;deleted
  12233   "RTN","VPR DJ04",72,0 )
  12234    ;
  12235   "RTN","VPR DJ04",73,0 )
  12236    S DATE=+$ P(X0,U,2), HLOC=+$G(^ DIC(42,+$P (X0,U,8),4 4))
  12237   "RTN","VPR DJ04",74,0 )
  12238    S X="H;"_ DATE,ADM(" localId")= X,ADM("uid ")=$$SETUI D^VPRUTILS ("appointm ent",DFN,X )
  12239   "RTN","VPR DJ04",75,0 )
  12240    S ADM("da teTime")=$ $JSONDT^VP RUTILS(DAT E)
  12241   "RTN","VPR DJ04",76,0 )
  12242    S FAC=$$F AC^VPRD(+H LOC) D FAC ILITY^VPRU TILS(FAC," ADM") I HL OC D
  12243   "RTN","VPR DJ04",77,0 )
  12244    . S HLOC= +HLOC_";"_ $P($G(^SC( +HLOC,0)), U)
  12245   "RTN","VPR DJ04",78,0 )
  12246    . S ADM(" uid")=ADM( "uid")_";" _+HLOC
  12247   "RTN","VPR DJ04",79,0 )
  12248    . S ADM(" locationNa me")=$P(HL OC,";",2)
  12249   "RTN","VPR DJ04",80,0 )
  12250    . S ADM(" locationUi d")=$$SETU ID^VPRUTIL S("locatio n",,+HLOC)
  12251   "RTN","VPR DJ04",81,0 )
  12252    . S X=$$G ET1^DIQ(44 ,+HLOC_"," ,8,"I"),X= $$AMIS^VPR DVSIT(X)
  12253   "RTN","VPR DJ04",82,0 )
  12254    . S:$L(X)  ADM("stop CodeUid")= "urn:va:st op-code:"_ $P(X,U),AD M("stopCod eName")=$P (X,U,2)
  12255   "RTN","VPR DJ04",83,0 )
  12256    . S SV=$$ GET1^DIQ(4 4,+HLOC_", ",9.5,"I")
  12257   "RTN","VPR DJ04",84,0 )
  12258    . I SV S  ADM("servi ce")=$$SER V^VPRDSDAM (SV)
  12259   "RTN","VPR DJ04",85,0 )
  12260    S X=+$P(X 0,U,5) I X  D
  12261   "RTN","VPR DJ04",86,0 )
  12262    . S ADM(" providers" ,1,"provid erUid")=$$ SETUID^VPR UTILS("use r",,X)
  12263   "RTN","VPR DJ04",87,0 )
  12264    . S ADM(" providers" ,1,"provid erName")=$ P($G(^VA(2 00,X,0)),U )
  12265   "RTN","VPR DJ04",88,0 )
  12266    S ADM("pa tientClass Code")="ur n:va:patie nt-class:I MP",ADM("p atientClas sName")="I npatient"
  12267   "RTN","VPR DJ04",89,0 )
  12268    S ADM("ca tegoryCode ")="urn:va :encounter -category: AD",ADM("c ategoryNam e")="Admis sion"
  12269   "RTN","VPR DJ04",90,0 )
  12270    S ADM("ap pointmentS tatus")=$S ($P(X0,U,1 7):"ADMITT ED",$P(X0, U,13):"CAN CELLED",1: "SCHEDULED ")
  12271   "RTN","VPR DJ04",91,0 )
  12272    D ADD^VPR DJ("ADM"," appointmen t")
  12273   "RTN","VPR DJ04",92,0 )
  12274    Q
  12275   "RTN","VPR DJ04",93,0 )
  12276    ;
  12277   "RTN","VPR DJ04",94,0 )
  12278   VSIT1(ID)  ; -- visit
  12279   "RTN","VPR DJ04",95,0 )
  12280    N VST,X0, X15,X,FAC, LOC,CATG,A MIS,INPT,D A
  12281   "RTN","VPR DJ04",96,0 )
  12282    I $G(ID)? 1"H"1.N D  ADM^VPRDJ0 4A(ID) Q
  12283   "RTN","VPR DJ04",97,0 )
  12284    I $D(^EDP (230,"V",I D)),$L($T( EDP1^VPRDJ 04E)) D ED P1^VPRDJ04 E(ID) Q
  12285   "RTN","VPR DJ04",98,0 )
  12286    D ENCEVEN T^PXAPI(ID )
  12287   "RTN","VPR DJ04",99,0 )
  12288    ;
  12289   "RTN","VPR DJ04",100, 0)
  12290    S X0=$G(^ TMP("PXKEN C",$J,ID," VST",ID,0) ),X15=$G(^ (150))
  12291   "RTN","VPR DJ04",101, 0)
  12292    ;Q:$P(X15 ,U,3)'="P"   Q:$P(X0, U,7)="E"   Q:$P(X0,U, 12)  ;prim ary, not h istorical  or child
  12293   "RTN","VPR DJ04",102, 0)
  12294    I $P(X0,U ,7)="H" D  ADM^VPRDJ0 4A(ID,+X0)  Q
  12295   "RTN","VPR DJ04",103, 0)
  12296    S VST("lo calId")=ID ,VST("uid" )=$$SETUID ^VPRUTILS( "visit",DF N,ID)
  12297   "RTN","VPR DJ04",104, 0)
  12298    S VST("da teTime")=$ $JSONDT^VP RUTILS(+X0 )
  12299   "RTN","VPR DJ04",105, 0)
  12300    S:$P(X0,U ,18) VST(" checkOut") =$$JSONDT^ VPRUTILS($ P(X0,U,18) )
  12301   "RTN","VPR DJ04",106, 0)
  12302    S:$P(X0,U ,12) VST(" parentUid" )=$$SETUID ^VPRUTILS( "visit",DF N,$P(X0,U, 12))
  12303   "RTN","VPR DJ04",107, 0)
  12304    S FAC=+$P (X0,U,6),C ATG=$P(X0, U,7),LOC=+ $P(X0,U,22 )
  12305   "RTN","VPR DJ04",108, 0)
  12306    S:FAC X=$ $STA^XUAF4 (FAC)_U_$P ($$NS^XUAF 4(FAC),U)
  12307   "RTN","VPR DJ04",109, 0)
  12308    S:'FAC X= $$FAC^VPRD (LOC) D FA CILITY^VPR UTILS(X,"V ST")
  12309   "RTN","VPR DJ04",110, 0)
  12310    S X=$S(CA TG="H":"AD ",CATG="C" :"CR",CATG ="T":"TC", CATG="N":" U",CATG="R ":"NH","D^ X"[CATG:"O ",1:"OV")
  12311   "RTN","VPR DJ04",111, 0)
  12312    S VST("ca tegoryCode ")="urn:va :encounter -category: "_X
  12313   "RTN","VPR DJ04",112, 0)
  12314    S VST("ca tegoryName ")=$S(X="A D":"Admiss ion",X="CR ":"Chart R eview",X=" TC":"Phone  Contact", X="U":"Unk nown",X="N H":"Nursin g Home",X= "O":"Other ",1:"Outpa tient Visi t")
  12315   "RTN","VPR DJ04",113, 0)
  12316    S INPT=$P (X15,U,2)  S:INPT=""  INPT=$S("H ^I^R^D"[CA TG:1,1:0)
  12317   "RTN","VPR DJ04",114, 0)
  12318    S X=$P(X1 5,U,3) S:$ L(X) VST(" encounterT ype")=X
  12319   "RTN","VPR DJ04",115, 0)
  12320    S X=$$CPT ^VPRDVSIT( ID) S:X VS T("typeNam e")=$P($$C PT^ICPTCOD (X),U,3)
  12321   "RTN","VPR DJ04",116, 0)
  12322    I 'X S VS T("typeNam e")=$S('IN PT&LOC:$P( $G(^SC(LOC ,0)),U)_"  VISIT",1:$ $CATG^VPRD VSIT(CATG) )
  12323   "RTN","VPR DJ04",117, 0)
  12324    S VST("pa tientClass Code")="ur n:va:patie nt-class:" _$S(INPT:" IMP",1:"AM B")
  12325   "RTN","VPR DJ04",118, 0)
  12326    S VST("pa tientClass Name")=$S( INPT:"Inpa tient",1:" Ambulatory ")
  12327   "RTN","VPR DJ04",119, 0)
  12328    S X=$P(X0 ,U,8) S:X  AMIS=$$AMI S^VPRDVSIT (X) I LOC  D
  12329   "RTN","VPR DJ04",120, 0)
  12330    . N L0 S  L0=$G(^SC( LOC,0))
  12331   "RTN","VPR DJ04",121, 0)
  12332    . I 'X S  AMIS=$$AMI S^VPRDVSIT ($P(L0,U,7 ))
  12333   "RTN","VPR DJ04",122, 0)
  12334    . S VST(" locationUi d")=$$SETU ID^VPRUTIL S("locatio n",,+LOC)
  12335   "RTN","VPR DJ04",123, 0)
  12336    . S VST(" locationNa me")=$P(L0 ,U)
  12337   "RTN","VPR DJ04",124, 0)
  12338    . S X=$$S ERV^VPRDVS IT($P(L0,U ,20)) S:$L (X) VST("s ervice")=X
  12339   "RTN","VPR DJ04",125, 0)
  12340    S:$D(AMIS ) VST("sto pCodeUid") ="urn:va:s top-code:" _$P(AMIS,U ),VST("sto pCodeName" )=$P(AMIS, U,2)
  12341   "RTN","VPR DJ04",126, 0)
  12342    S X=$$POV ^VPRDVSIT( ID) S:$L(X ) VST("rea sonUid")=$ $SETNCS^VP RUTILS("ic d",$P(X,U) ),VST("rea sonName")= $P(X,U,2)
  12343   "RTN","VPR DJ04",127, 0)
  12344    ; provide r(s)
  12345   "RTN","VPR DJ04",128, 0)
  12346    S DA=0 F   S DA=$O(^ TMP("PXKEN C",$J,ID," PRV",DA))  Q:DA<1  S  X0=$G(^(DA ,0)) D
  12347   "RTN","VPR DJ04",129, 0)
  12348    . I $P(X0 ,U,4)="P"  D PROV("VS T",DA,+X0, "P",1) Q   ;primary
  12349   "RTN","VPR DJ04",130, 0)
  12350    . D PROV( "VST",DA,+ X0,"S")                          ;secondary
  12351   "RTN","VPR DJ04",131, 0)
  12352    K ^TMP("P XKENC",$J, ID)
  12353   "RTN","VPR DJ04",132, 0)
  12354    D ADD^VPR DJ("VST"," visit")
  12355   "RTN","VPR DJ04",133, 0)
  12356    Q
  12357   "RTN","VPR DJ04",134, 0)
  12358    ;
  12359   "RTN","VPR DJ04",135, 0)
  12360   PROV(ARR,I ,IEN,ROLE, PRIM) ; --  add provi ders
  12361   "RTN","VPR DJ04",136, 0)
  12362    S @ARR@(" providers" ,I,"provid erUid")=$$ SETUID^VPR UTILS("use r",,+IEN)
  12363   "RTN","VPR DJ04",137, 0)
  12364    S @ARR@(" providers" ,I,"provid erName")=$ P($G(^VA(2 00,+IEN,0) ),U)
  12365   "RTN","VPR DJ04",138, 0)
  12366    S @ARR@(" providers" ,I,"role") =ROLE
  12367   "RTN","VPR DJ04",139, 0)
  12368    S:$G(PRIM ) @ARR@("p roviders", I,"primary ")="true"
  12369   "RTN","VPR DJ04",140, 0)
  12370    Q
  12371   "RTN","VPR DJ04",141, 0)
  12372    ;
  12373   "RTN","VPR DJ04",142, 0)
  12374   NAME(IEN)  ; -- Retur n a string  'name' fo r the visi t
  12375   "RTN","VPR DJ04",143, 0)
  12376    N Y,X0,LO C,DATE
  12377   "RTN","VPR DJ04",144, 0)
  12378    S X0=$G(^ AUPNVSIT(+ $G(IEN),0) ),Y=""
  12379   "RTN","VPR DJ04",145, 0)
  12380    S DATE=+X 0,LOC=+$P( X0,U,22) S :LOC LOC=$ P($G(^SC(L OC,0)),U)_ " "
  12381   "RTN","VPR DJ04",146, 0)
  12382    S Y=LOC_$ $FMTE^XLFD T(DATE,"1D ") ;Mon DD , YYYY
  12383   "RTN","VPR DJ04",147, 0)
  12384    Q Y
  12385   "RTN","VPR DJ04A")
  12386   0^81^B3600 7346
  12387   "RTN","VPR DJ04A",1,0 )
  12388   VPRDJ04A ; SLC/MKB --  Admission s,PTF ;7/2 5/13
  12389   "RTN","VPR DJ04A",2,0 )
  12390    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  12391   "RTN","VPR DJ04A",3,0 )
  12392    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  12393   "RTN","VPR DJ04A",4,0 )
  12394    ;
  12395   "RTN","VPR DJ04A",5,0 )
  12396    ; Externa l Referenc es           DBIA#
  12397   "RTN","VPR DJ04A",6,0 )
  12398    ; ------- ---------- --           -----
  12399   "RTN","VPR DJ04A",7,0 )
  12400    ; ^AUPNVS IT                       2028
  12401   "RTN","VPR DJ04A",8,0 )
  12402    ; ^DGPM                            1865
  12403   "RTN","VPR DJ04A",9,0 )
  12404    ; ^DIC(42                         10039
  12405   "RTN","VPR DJ04A",10, 0)
  12406    ; ^DPT                            10035
  12407   "RTN","VPR DJ04A",11, 0)
  12408    ; ^SC                             10040
  12409   "RTN","VPR DJ04A",12, 0)
  12410    ; ^VA(200                         10060
  12411   "RTN","VPR DJ04A",13, 0)
  12412    ; DGPTFAP I                        3157
  12413   "RTN","VPR DJ04A",14, 0)
  12414    ; DIC                              2051
  12415   "RTN","VPR DJ04A",15, 0)
  12416    ; DILFD                            2055
  12417   "RTN","VPR DJ04A",16, 0)
  12418    ; DIQ                              2056
  12419   "RTN","VPR DJ04A",17, 0)
  12420    ; ICDCODE                          3990
  12421   "RTN","VPR DJ04A",18, 0)
  12422    ; ICPTCOD                          1995
  12423   "RTN","VPR DJ04A",19, 0)
  12424    ; VADPT                           10061
  12425   "RTN","VPR DJ04A",20, 0)
  12426    ; XUAF4                            2171
  12427   "RTN","VPR DJ04A",21, 0)
  12428    ;
  12429   "RTN","VPR DJ04A",22, 0)
  12430    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  12431   "RTN","VPR DJ04A",23, 0)
  12432    ;
  12433   "RTN","VPR DJ04A",24, 0)
  12434   ADM(ID,DAT E) ; -- ad mission [f rom VSIT1]
  12435   "RTN","VPR DJ04A",25, 0)
  12436    N ADM,VAD MVT,VAIP,V AERR,MVT,S PEC,HLOC,F AC,ICD,I
  12437   "RTN","VPR DJ04A",26, 0)
  12438    S ID=$G(I D),DATE=+$ G(DATE) Q: ID=""  ;Q: DATE<1
  12439   "RTN","VPR DJ04A",27, 0)
  12440    I ID S VA IP("D")=DA TE,VST=+ID
  12441   "RTN","VPR DJ04A",28, 0)
  12442    I ID?1"H" 1.N S VAIP ("E")=+$E( ID,2,99),V ST=0
  12443   "RTN","VPR DJ04A",29, 0)
  12444    D IN5^VAD PT Q:'$G(V AIP(1))  ; deleted
  12445   "RTN","VPR DJ04A",30, 0)
  12446    S VADMVT= +$G(VAIP(1 3)),ID="H" _VADMVT
  12447   "RTN","VPR DJ04A",31, 0)
  12448    S ADM("lo calId")=ID ,ADM("uid" )=$$SETUID ^VPRUTILS( "visit",DF N,ID)
  12449   "RTN","VPR DJ04A",32, 0)
  12450    S:'DATE D ATE=+$G(VA IP(13,1))  S:'VST VST =$$VISIT(D FN,DATE)
  12451   "RTN","VPR DJ04A",33, 0)
  12452    S (ADM("d ateTime"), ADM("stay" ,"arrivalD ateTime")) =$$JSONDT^ VPRUTILS(D ATE)
  12453   "RTN","VPR DJ04A",34, 0)
  12454    S:$L($P(V AIP(6),U,2 )) ADM("ro omBed")=$P (VAIP(6),U ,2)
  12455   "RTN","VPR DJ04A",35, 0)
  12456    S MVT=13, I=0 I VADM VT=$G(^DPT (DFN,.105) ) D  ;if c urrent adm ission,
  12457   "RTN","VPR DJ04A",36, 0)
  12458    . S ADM(" current")= "true",MVT =14             ; use  last move ment info
  12459   "RTN","VPR DJ04A",37, 0)
  12460    . S X=$G( ^DPT(DFN,. 101)) S:$L (X) ADM("r oomBed")=X
  12461   "RTN","VPR DJ04A",38, 0)
  12462    . K VPRAD MIT                                   ;kill  flag from  VPRDJ0
  12463   "RTN","VPR DJ04A",39, 0)
  12464    S SPEC=$G (VAIP(MVT, 6)),ADM("s pecialty") =$P(SPEC,U ,2)
  12465   "RTN","VPR DJ04A",40, 0)
  12466    S X=$$SER V^VPRDVSIT (+SPEC),AD M("service ")=X
  12467   "RTN","VPR DJ04A",41, 0)
  12468    S HLOC=+$ G(^DIC(42, +$G(VAIP(M VT,4)),44) ),FAC=$$FA C^VPRD(+HL OC) I HLOC  D
  12469   "RTN","VPR DJ04A",42, 0)
  12470    . S ADM(" locationUi d")=$$SETU ID^VPRUTIL S("locatio n",,+HLOC)
  12471   "RTN","VPR DJ04A",43, 0)
  12472    . S ADM(" locationNa me")=$P($G (^SC(HLOC, 0)),U)
  12473   "RTN","VPR DJ04A",44, 0)
  12474    . S X=$$A MIS^VPRDVS IT($P($G(^ SC(HLOC,0) ),U,7))
  12475   "RTN","VPR DJ04A",45, 0)
  12476    . S:$L($G (X)) ADM(" stopCodeUi d")="urn:v a:stop-cod e:"_$P(X,U ),ADM("sto pCodeName" )=$P(X,U,2 )
  12477   "RTN","VPR DJ04A",46, 0)
  12478    . S ADM(" summary")= "${"_ADM(" service")_ "}:"_ADM(" locationNa me")
  12479   "RTN","VPR DJ04A",47, 0)
  12480    D FACILIT Y^VPRUTILS (FAC,"ADM" )
  12481   "RTN","VPR DJ04A",48, 0)
  12482    S ADM("ca tegoryCode ")="urn:va :encounter -category: AD",ADM("c ategoryNam e")="Admis sion"
  12483   "RTN","VPR DJ04A",49, 0)
  12484    S ADM("pa tientClass Code")="ur n:va:patie nt-class:I MP",ADM("p atientClas sName")="I npatient"
  12485   "RTN","VPR DJ04A",50, 0)
  12486    I $G(VAIP (17)) S AD M("stay"," dischargeD ateTime")= $$JSONDT^V PRUTILS(+$ G(VAIP(17, 1)))
  12487   "RTN","VPR DJ04A",51, 0)
  12488    I $G(VAIP (18)) S I= I+1 D PROV ("ADM",I,+ VAIP(18)," A")          ;attendi ng
  12489   "RTN","VPR DJ04A",52, 0)
  12490    I $G(VAIP (MVT,5)) S  I=I+1 D P ROV("ADM", I,+VAIP(MV T,5),"P",1 ) ;primary
  12491   "RTN","VPR DJ04A",53, 0)
  12492    S ICD=$$P OV^VPRDVSI T(VST) S:' ICD ICD=$$ PTF^VPRDVS IT(DFN,VAI P(12)) ;PT F>ICD
  12493   "RTN","VPR DJ04A",54, 0)
  12494    I $L(ICD) <2 S ADM(" reasonName ")=$G(VAIP (MVT,7))
  12495   "RTN","VPR DJ04A",55, 0)
  12496    E  S ADM( "reasonUid ")=$$SETNC S^VPRUTILS ("icd",ICD ),ADM("rea sonName")= $P(ICD,U,2 )
  12497   "RTN","VPR DJ04A",56, 0)
  12498    S X=$$CPT ^VPRDVSIT( VST),ADM(" typeName") =$S(X:$P($ $CPT^ICPTC OD(X),U,3) ,1:$$CATG^ VPRDVSIT(" H"))
  12499   "RTN","VPR DJ04A",57, 0)
  12500    D MVT(VAD MVT)   ;su b-movement s
  12501   "RTN","VPR DJ04A",58, 0)
  12502    ; TIU(VST ,.ADM) ;no tes/summar y
  12503   "RTN","VPR DJ04A",59, 0)
  12504    D ADD^VPR DJ("ADM"," visit")
  12505   "RTN","VPR DJ04A",60, 0)
  12506    Q
  12507   "RTN","VPR DJ04A",61, 0)
  12508    ;
  12509   "RTN","VPR DJ04A",62, 0)
  12510   TIU(VISIT, ARR) ; --  add notes  to ARR("do cument")
  12511   "RTN","VPR DJ04A",63, 0)
  12512    N X,Y,I,V PRX,LT,NT, DA,CNT,VPR Y
  12513   "RTN","VPR DJ04A",64, 0)
  12514    D FIND^DI C(8925,,.0 1,"QX",+$G (VISIT),," V",,,"VPRX ")
  12515   "RTN","VPR DJ04A",65, 0)
  12516    S Y="",(I ,CNT)=0
  12517   "RTN","VPR DJ04A",66, 0)
  12518    F  S I=$O (VPRX("DIL IST",1,I))  Q:I<1  D
  12519   "RTN","VPR DJ04A",67, 0)
  12520    . S LT=$G (VPRX("DIL IST","ID", I,.01)) Q: $P(LT," ") ="Addendum "
  12521   "RTN","VPR DJ04A",68, 0)
  12522    . S DA=$G (VPRX("DIL IST",2,I))
  12523   "RTN","VPR DJ04A",69, 0)
  12524    . S NT=$$ GET1^DIQ(8 925,+DA_", ",".01:150 1")
  12525   "RTN","VPR DJ04A",70, 0)
  12526    . S CNT=C NT+1,ARR(" documents" ,CNT,"uid" )=$$SETUID ^VPRUTILS( "document" ,DFN,+DA)
  12527   "RTN","VPR DJ04A",71, 0)
  12528    . S ARR(" documents" ,CNT,"loca lTitle")=L T
  12529   "RTN","VPR DJ04A",72, 0)
  12530    . S:$L(NT ) ARR("doc uments",CN T,"nationa lTitle")=N T
  12531   "RTN","VPR DJ04A",73, 0)
  12532    Q
  12533   "RTN","VPR DJ04A",74, 0)
  12534    ;
  12535   "RTN","VPR DJ04A",75, 0)
  12536   PROV(ARR,I ,IEN,ROLE, PRIM) ; --  add provi ders
  12537   "RTN","VPR DJ04A",76, 0)
  12538    S @ARR@(" providers" ,I,"provid erUid")=$$ SETUID^VPR UTILS("use r",,+IEN)
  12539   "RTN","VPR DJ04A",77, 0)
  12540    S @ARR@(" providers" ,I,"provid erName")=$ P($G(^VA(2 00,+IEN,0) ),U)
  12541   "RTN","VPR DJ04A",78, 0)
  12542    S @ARR@(" providers" ,I,"role") =ROLE
  12543   "RTN","VPR DJ04A",79, 0)
  12544    S:$G(PRIM ) @ARR@("p roviders", I,"primary ")="true"
  12545   "RTN","VPR DJ04A",80, 0)
  12546    Q
  12547   "RTN","VPR DJ04A",81, 0)
  12548    ;
  12549   "RTN","VPR DJ04A",82, 0)
  12550   MVT(CA) ;  -- add mov ements to  ADM("movem ent",i,"at tribute")
  12551   "RTN","VPR DJ04A",83, 0)
  12552    N DATE,DA ,CNT,X S ( DATE,CNT)= 0
  12553   "RTN","VPR DJ04A",84, 0)
  12554    F  S DATE =$O(^DGPM( "APCA",DFN ,CA,DATE))  Q:DATE<1   S DA=+$O( ^(DATE,0))  I DA'=CA  D
  12555   "RTN","VPR DJ04A",85, 0)
  12556    . S X0=$G (^DGPM(DA, 0)),CNT=CN T+1
  12557   "RTN","VPR DJ04A",86, 0)
  12558    . S ADM(" movements" ,CNT,"loca lId")=DA
  12559   "RTN","VPR DJ04A",87, 0)
  12560    . S ADM(" movements" ,CNT,"date Time")=$$J SONDT^VPRU TILS(DATE)
  12561   "RTN","VPR DJ04A",88, 0)
  12562    . S ADM(" movements" ,CNT,"move mentType") =$$EXTERNA L^DILFD(40 5,.02,,$P( X0,U,2))
  12563   "RTN","VPR DJ04A",89, 0)
  12564    . S X=+$P (X0,U,19)  I X D
  12565   "RTN","VPR DJ04A",90, 0)
  12566    .. S ADM( "movements ",CNT,"pro viderUid") =$$SETUID^ VPRUTILS(" user",,X)
  12567   "RTN","VPR DJ04A",91, 0)
  12568    .. S ADM( "movements ",CNT,"pro viderName" )=$P($G(^V A(200,X,0) ),U)
  12569   "RTN","VPR DJ04A",92, 0)
  12570    . S X=+$P (X0,U,9)
  12571   "RTN","VPR DJ04A",93, 0)
  12572    . S:X ADM ("movement s",CNT,"sp ecialty")= $$EXTERNAL ^DILFD(405 ,.09,,X)
  12573   "RTN","VPR DJ04A",94, 0)
  12574    . S HLOC= +$G(^DIC(4 2,+$P(X0,U ,6),44)),F AC=$$FAC^V PRD(HLOC)  I HLOC D
  12575   "RTN","VPR DJ04A",95, 0)
  12576    .. S ADM( "movements ",CNT,"loc ationUid") =$$SETUID^ VPRUTILS(" location", ,HLOC)
  12577   "RTN","VPR DJ04A",96, 0)
  12578    .. S ADM( "movements ",CNT,"loc ationName" )=$P($G(^S C(HLOC,0)) ,U)
  12579   "RTN","VPR DJ04A",97, 0)
  12580    Q
  12581   "RTN","VPR DJ04A",98, 0)
  12582    ;
  12583   "RTN","VPR DJ04A",99, 0)
  12584   PTFA(ID) ;  -- find I D in ^PXRM INDX(FNUM) , fall thr u to PX1 i f successf ul
  12585   "RTN","VPR DJ04A",100 ,0)
  12586    N ROOT,ID X,ITEM,DAT E K ^TMP(" VPRPX",$J)
  12587   "RTN","VPR DJ04A",101 ,0)
  12588    S P=$L(ID ,";"),TYPE =$P(ID,";" ,P),ID=$P( ID,";",1,P -1)
  12589   "RTN","VPR DJ04A",102 ,0)
  12590    S ROOT="^ PXRMINDX(4 5,""ICD9"" ,""PNI""," _+$G(DFN)_ ","_""""_T YPE_""""
  12591   "RTN","VPR DJ04A",103 ,0)
  12592    S IDX=ROO T_")" F  S  IDX=$Q(@I DX) Q:$P(I DX,",",1,5 )'=ROOT  D
  12593   "RTN","VPR DJ04A",104 ,0)
  12594    . I """"_ ID_""")"'= $P(IDX,"," ,8) Q
  12595   "RTN","VPR DJ04A",105 ,0)
  12596    . S DATE= +$P(IDX,", ",7),ITEM= +$P(IDX,", ",6)
  12597   "RTN","VPR DJ04A",106 ,0)
  12598    . S VPRID T=9999999- DATE,^TMP( "VPRPX",$J ,VPRIDT,ID _";"_TYPE) =ITEM_U_DA TE
  12599   "RTN","VPR DJ04A",107 ,0)
  12600    Q:'$D(^TM P("VPRPX", $J))  ;not  found
  12601   "RTN","VPR DJ04A",108 ,0)
  12602    S ID=ID_" ;"_TYPE
  12603   "RTN","VPR DJ04A",109 ,0)
  12604   PTF1 ; --  PTF where  ID=iens;TY PE
  12605   "RTN","VPR DJ04A",110 ,0)
  12606    ;   Expec ts ^TMP("V PRPX",$J,V PRIDT,ID)= ITM^[DISCH ARGE]DATE
  12607   "RTN","VPR DJ04A",111 ,0)
  12608    N TMP,PTF ,ADM,DIS,V AIN,VAINDT ,HLOC,FAC, X,Y,VISIT, X0
  12609   "RTN","VPR DJ04A",112 ,0)
  12610    ; PTF^DGP TPXRM(+ID, .VPRF)
  12611   "RTN","VPR DJ04A",113 ,0)
  12612    S TMP=$G( ^TMP("VPRP X",$J,VPRI DT,ID))
  12613   "RTN","VPR DJ04A",114 ,0)
  12614    N $ES,$ET ,ERRPAT,ER RMSG
  12615   "RTN","VPR DJ04A",115 ,0)
  12616    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  12617   "RTN","VPR DJ04A",116 ,0)
  12618    S ERRMSG= "A problem  occurred  converting  a record  for the pt f domain"
  12619   "RTN","VPR DJ04A",117 ,0)
  12620    ;
  12621   "RTN","VPR DJ04A",118 ,0)
  12622    S PTF("lo calId")=ID ,PTF("uid" )=$$SETUID ^VPRUTILS( "ptf",DFN, ID)
  12623   "RTN","VPR DJ04A",119 ,0)
  12624    S P=$L(ID ,";"),TYPE =$P(ID,";" ,P) S:TYPE ="DXLS" PT F("princip alDx")="tr ue"
  12625   "RTN","VPR DJ04A",120 ,0)
  12626    S X=$$ICD DX^ICDCODE ($P(TMP,U) ,$P(TMP,U, 2)),Y=$S($ P(X,U,4)'= "":$P(X,U, 4),1:$P(X, U,2))
  12627   "RTN","VPR DJ04A",121 ,0)
  12628    S PTF("ic dCode")=$$ SETNCS^VPR UTILS("icd ",$P(X,U,2 )),PTF("ic dName")=Y
  12629   "RTN","VPR DJ04A",122 ,0)
  12630    S DIS=$P( TMP,U,2) S :DIS 
D NS    T=DIS-.000 1
  12631   "RTN","VPR DJ04A",123 ,0)
  12632    D INP^VAD PT Q:'$G(V AIN(1))  ; admission  not found
  12633   "RTN","VPR DJ04A",124 ,0)
  12634    S PTF("ad missionUid ")=$$SETUI D^VPRUTILS ("visit",D FN,"H"_VAI N(1))
  12635   "RTN","VPR DJ04A",125 ,0)
  12636    S ADM=+$G (VAIN(7)), HLOC=+$G(^ DIC(42,+$G (VAIN(4)), 44))
  12637   "RTN","VPR DJ04A",126 ,0)
  12638    S:ADM PTF ("arrivalD ateTime")= $$JSONDT^V PRUTILS(AD M)
  12639   "RTN","VPR DJ04A",127 ,0)
  12640    S:DIS PTF ("discharg eDateTime" )=$$JSONDT ^VPRUTILS( DIS)
  12641   "RTN","VPR DJ04A",128 ,0)
  12642    S FAC=$$F AC^VPRD(HL OC) D:FAC  FACILITY^V PRUTILS(FA C,"PTF")
  12643   "RTN","VPR DJ04A",129 ,0)
  12644    D ADD^VPR DJ("PTF"," ptf")
  12645   "RTN","VPR DJ04A",130 ,0)
  12646    Q
  12647   "RTN","VPR DJ04A",131 ,0)
  12648    ;
  12649   "RTN","VPR DJ04A",132 ,0)
  12650   VISIT(DFN, DATE) ; --  Return vi sit# for a dmission
  12651   "RTN","VPR DJ04A",133 ,0)
  12652    N X,Y
  12653   "RTN","VPR DJ04A",134 ,0)
  12654    S X=99999 99-$P(DATE ,".")_"."_ $P(DATE,". ",2)
  12655   "RTN","VPR DJ04A",135 ,0)
  12656    S Y=+$O(^ AUPNVSIT(" AAH",DFN,X ,0))
  12657   "RTN","VPR DJ04A",136 ,0)
  12658    Q Y
  12659   "RTN","VPR DJ04E")
  12660   0^49^B1017 0703
  12661   "RTN","VPR DJ04E",1,0 )
  12662   VPRDJ04E ; SLC/MKB --  EDIS ;6/2 5/12  16:1 1
  12663   "RTN","VPR DJ04E",2,0 )
  12664    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  12665   "RTN","VPR DJ04E",3,0 )
  12666    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  12667   "RTN","VPR DJ04E",4,0 )
  12668    ;
  12669   "RTN","VPR DJ04E",5,0 )
  12670    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  12671   "RTN","VPR DJ04E",6,0 )
  12672    ;
  12673   "RTN","VPR DJ04E",7,0 )
  12674    ;
  12675   "RTN","VPR DJ04E",8,0 )
  12676   EDP1(ID) ;  -- ED vis it
  12677   "RTN","VPR DJ04E",9,0 )
  12678    N DA,EDP, X0,VST,FAC ,LOC,LOC0, X,I,ICD
  12679   "RTN","VPR DJ04E",10, 0)
  12680    S DA=+$O( ^EDP(230," V",+$G(ID) ,0)) Q:DA< 1
  12681   "RTN","VPR DJ04E",11, 0)
  12682    S EDP=$G( ^EDP(230,D A,0)),X0=$ G(^AUPNVSI T(ID,0))
  12683   "RTN","VPR DJ04E",12, 0)
  12684    ;
  12685   "RTN","VPR DJ04E",13, 0)
  12686    S VST("lo calId")=ID ,VST("uid" )=$$SETUID ^VPRUTILS( "visit",DF N,ID)
  12687   "RTN","VPR DJ04E",14, 0)
  12688    S VST("da teTime")=$ $JSONDT^VP RUTILS(+X0 )
  12689   "RTN","VPR DJ04E",15, 0)
  12690    S:$P(EDP, U,8) VST(" stay","arr ivalDateTi me")=$$JSO NDT^VPRUTI LS($P(EDP, U,8))
  12691   "RTN","VPR DJ04E",16, 0)
  12692    S:$P(EDP, U,9) VST(" stay","dis chargeDate Time")=$$J SONDT^VPRU TILS($P(ED P,U,9))
  12693   "RTN","VPR DJ04E",17, 0)
  12694    S FAC=+$P (EDP,U,2), LOC=+$P(ED P,U,14),LO C0=$S(LOC: $G(^SC(LOC ,0)),1:"")
  12695   "RTN","VPR DJ04E",18, 0)
  12696    S:FAC X=$ $STA^XUAF4 (FAC)_U_$P ($$NS^XUAF 4(FAC),U)
  12697   "RTN","VPR DJ04E",19, 0)
  12698    S:'FAC X= $$FAC^VPRD (LOC) D FA CILITY^VPR UTILS(X,"V ST")
  12699   "RTN","VPR DJ04E",20, 0)
  12700    S VST("ca tegoryCode ")="urn:va :encounter -category: OV"
  12701   "RTN","VPR DJ04E",21, 0)
  12702    S VST("ca tegoryName ")="Outpat ient Visit "
  12703   "RTN","VPR DJ04E",22, 0)
  12704    S VST("pa tientClass Code")="ur n:va:patie nt-class:E MER"
  12705   "RTN","VPR DJ04E",23, 0)
  12706    S VST("pa tientClass Name")="Em ergency"
  12707   "RTN","VPR DJ04E",24, 0)
  12708    ;
  12709   "RTN","VPR DJ04E",25, 0)
  12710    S X=$$CPT ^VPRDVSIT( ID) S:X VS T("typeNam e")=$P($$C PT^ICPTCOD (X),U,3)
  12711   "RTN","VPR DJ04E",26, 0)
  12712    I 'X S VS T("typeNam e")=$S(LOC :$P(LOC0,U )_" VISIT" ,1:"EMERGE NCY")
  12713   "RTN","VPR DJ04E",27, 0)
  12714    S X=$P(X0 ,U,8) S:X  AMIS=$$AMI S^VPRDVSIT (X) I LOC  D
  12715   "RTN","VPR DJ04E",28, 0)
  12716    . I 'X S  AMIS=$$AMI S^VPRDVSIT ($P(LOC0,U ,7))
  12717   "RTN","VPR DJ04E",29, 0)
  12718    . S VST(" locationUi d")=$$SETU ID^VPRUTIL S("locatio n",,+LOC)
  12719   "RTN","VPR DJ04E",30, 0)
  12720    . S VST(" locationNa me")=$P(LO C0,U)
  12721   "RTN","VPR DJ04E",31, 0)
  12722    . S X=$$S ERV^VPRDVS IT($P(LOC0 ,U,20)) Q: X=""
  12723   "RTN","VPR DJ04E",32, 0)
  12724    . S:$L(X)  VST("serv ice")=X,VS T("summary ")="${"_VS T("service ")_"}:"_$P (LOC0,U)
  12725   "RTN","VPR DJ04E",33, 0)
  12726    S:$G(AMIS ) VST("sto pCodeUid") ="urn:va:s top-code:" _$P(AMIS,U ),VST("sto pCodeName" )=$P(AMIS, U,2)
  12727   "RTN","VPR DJ04E",34, 0)
  12728    ; X=$$POV ^VPRDVSIT( ID) S:$L(X ) VST("rea sonUid")=$ $SETNCS^VP RUTILS("ic d",$P(X,U) ),VST("rea sonName")= $P(X,U,2)
  12729   "RTN","VPR DJ04E",35, 0)
  12730    ;
  12731   "RTN","VPR DJ04E",36, 0)
  12732    S VST("re asonName") =$P($G(^ED P(230,+DA, 1)),U)
  12733   "RTN","VPR DJ04E",37, 0)
  12734    S I=0 F   S I=$O(^ED P(230,+DA, 4,I)) Q:I< 1  I $P($G (^(I,0)),U ,3) D  ;pr imary Dx
  12735   "RTN","VPR DJ04E",38, 0)
  12736    . S X=$G( ^EDP(230,+ DA,4,I,0)) ,VST("reas onName")=$ P(X,U) Q:' $P(X,U,2)
  12737   "RTN","VPR DJ04E",39, 0)
  12738    . S ICD=$ $ICD^VPRDV SIT($P(X,U ,2)) Q:$L( ICD)'>1
  12739   "RTN","VPR DJ04E",40, 0)
  12740    . S VST(" reasonUid" )=$$SETNCS ^VPRUTILS( "icd",$P(I CD,U)),VST ("reasonNa me")=$P(IC D,U,2)
  12741   "RTN","VPR DJ04E",41, 0)
  12742    ;
  12743   "RTN","VPR DJ04E",42, 0)
  12744    ; provide r(s)
  12745   "RTN","VPR DJ04E",43, 0)
  12746    S EDP=$G( ^EDP(230,D A,3)),I=0
  12747   "RTN","VPR DJ04E",44, 0)
  12748    I $P(EDP, U,5) S I=I +1 D PROV( "VST",I,+$ P(EDP,U,5) ,"P",1) ;p rimary/MD
  12749   "RTN","VPR DJ04E",45, 0)
  12750    I $P(EDP, U,6) S I=I +1 D PROV( "VST",I,+$ P(EDP,U,6) ,"N")   ;n urse
  12751   "RTN","VPR DJ04E",46, 0)
  12752    I $P(EDP, U,7) S I=I +1 D PROV( "VST",I,+$ P(EDP,U,7) ,"R")   ;r esident
  12753   "RTN","VPR DJ04E",47, 0)
  12754    S:$L($P(E DP,U,8)) V ST("commen t")=$P(EDP ,U,8)
  12755   "RTN","VPR DJ04E",48, 0)
  12756    S:$P(EDP, U,2) VST(" appointmen tStatus")= $$NAME(+$P (EDP,U,2))
  12757   "RTN","VPR DJ04E",49, 0)
  12758    ;
  12759   "RTN","VPR DJ04E",50, 0)
  12760    ; note(s)
  12761   "RTN","VPR DJ04E",51, 0)
  12762    ; TIU^VPR DJ04A(ID,. VST)
  12763   "RTN","VPR DJ04E",52, 0)
  12764    K ^TMP("P XKENC",$J, ID)
  12765   "RTN","VPR DJ04E",53, 0)
  12766    D ADD^VPR DJ("VST"," visit")
  12767   "RTN","VPR DJ04E",54, 0)
  12768    Q
  12769   "RTN","VPR DJ04E",55, 0)
  12770    ;
  12771   "RTN","VPR DJ04E",56, 0)
  12772   PROV(ARR,I ,IEN,ROLE, PRIM) ; --  add provi ders
  12773   "RTN","VPR DJ04E",57, 0)
  12774    S @ARR@(" providers" ,I,"provid erUid")=$$ SETUID^VPR UTILS("use r",,+IEN)
  12775   "RTN","VPR DJ04E",58, 0)
  12776    S @ARR@(" providers" ,I,"provid erName")=$ P($G(^VA(2 00,+IEN,0) ),U)
  12777   "RTN","VPR DJ04E",59, 0)
  12778    S @ARR@(" providers" ,I,"role") =ROLE
  12779   "RTN","VPR DJ04E",60, 0)
  12780    S:$G(PRIM ) @ARR@("p roviders", I,"primary ")="true"
  12781   "RTN","VPR DJ04E",61, 0)
  12782    Q
  12783   "RTN","VPR DJ04E",62, 0)
  12784    ;
  12785   "RTN","VPR DJ04E",63, 0)
  12786   NAME(X) ;  -- name of  a code in  #233.1
  12787   "RTN","VPR DJ04E",64, 0)
  12788    N Y S Y=$ P($G(^EDPB (233.1,+$G (X),0)),U, 2)
  12789   "RTN","VPR DJ04E",65, 0)
  12790    Q Y
  12791   "RTN","VPR DJ05")
  12792   0^75^B7863 7701
  12793   "RTN","VPR DJ05",1,0)
  12794   VPRDJ05 ;S LC/MKB --  Medication s by order  ;8/2/11   15:29
  12795   "RTN","VPR DJ05",2,0)
  12796    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  12797   "RTN","VPR DJ05",3,0)
  12798    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  12799   "RTN","VPR DJ05",4,0)
  12800    ;
  12801   "RTN","VPR DJ05",5,0)
  12802    ; Externa l Referenc es: see VP RDJ05V for  DBIA list
  12803   "RTN","VPR DJ05",6,0)
  12804    ;
  12805   "RTN","VPR DJ05",7,0)
  12806    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  12807   "RTN","VPR DJ05",8,0)
  12808    ;
  12809   "RTN","VPR DJ05",9,0)
  12810   PS1(ID) ;  -- med ord er
  12811   "RTN","VPR DJ05",10,0 )
  12812    N $ES,$ET ,ERRPAT,ER RMSG
  12813   "RTN","VPR DJ05",11,0 )
  12814    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  12815   "RTN","VPR DJ05",12,0 )
  12816    S ERRMSG= "A problem  occurred  converting  order "_I D_" for th e medicati on domain"
  12817   "RTN","VPR DJ05",13,0 )
  12818    N ORPK,TY PE S ID=+$ G(ID)
  12819   "RTN","VPR DJ05",14,0 )
  12820    S ORPK=$$ PKGID^ORX8 (ID),TYPE= $E(ORPK,$L (ORPK)) S: TYPE=+TYPE  TYPE="R"
  12821   "RTN","VPR DJ05",15,0 )
  12822    ;
  12823   "RTN","VPR DJ05",16,0 )
  12824    N ORUPCHU K,ORVP,ORP CL,ORDUZ,O RODT,ORSTR T,ORSTOP,O RL,ORTO,OR STS,ORNP,O RPV,ORTX
  12825   "RTN","VPR DJ05",17,0 )
  12826    N MED,CLS ,OI,X,LOC, FAC,DRUG,D A,CNT,VPRE SP
  12827   "RTN","VPR DJ05",18,0 )
  12828    S X=$S(OR PK:$E(ORPK ,$L(ORPK)) ,1:"Z") S: X=+X X="R"  ;last cha r = PS fil e
  12829   "RTN","VPR DJ05",19,0 )
  12830    S CLS=$S( "RSN"[X:"O ","UV"[X:" I",1:$$GET 1^DIQ(100, ID_",",10, "I"))
  12831   "RTN","VPR DJ05",20,0 )
  12832    S MED("ui d")=$$SETU ID^VPRUTIL S("med",DF N,ID)
  12833   "RTN","VPR DJ05",21,0 )
  12834    S MED("or ders",1,"o rderUid")= $$SETUID^V PRUTILS("o rder",DFN, ID)
  12835   "RTN","VPR DJ05",22,0 )
  12836    S X=$$GET 1^DIQ(100, ID_",",9," I") S:X ME D("orders" ,1,"predec essor")=$$ SETUID^VPR UTILS("med ",DFN,+X)
  12837   "RTN","VPR DJ05",23,0 )
  12838    S X=$$GET 1^DIQ(100, ID_",",9.1 ,"I") S:X  MED("order s",1,"succ essor")=$$ SETUID^VPR UTILS("med ",DFN,+X)
  12839   "RTN","VPR DJ05",24,0 )
  12840    S:ORPK ME D("localId ")=ORPK_"; "_CLS
  12841   "RTN","VPR DJ05",25,0 )
  12842    D EN^ORX8 (ID) S X=" " F  S X=$ O(ORUPCHUK (X)) Q:X=" "  S:$D(OR UPCHUK(X)) #2 @X=ORUP CHUK(X)
  12843   "RTN","VPR DJ05",26,0 )
  12844    S:$G(OROD T) MED("or ders",1,"o rdered")=$ $JSONDT^VP RUTILS(ORO DT)
  12845   "RTN","VPR DJ05",27,0 )
  12846    S:$G(ORNP ) MED("ord ers",1,"pr oviderUid" )=$$SETUID ^VPRUTILS( "user",,+O RNP),MED(" orders",1, "providerN ame")=$P(O RNP,U,2)
  12847   "RTN","VPR DJ05",28,0 )
  12848    S LOC=+$G (ORL),FAC= $$FAC^VPRD (LOC) I LO C D
  12849   "RTN","VPR DJ05",29,0 )
  12850    . S MED(" orders",1, "locationU id")=$$SET UID^VPRUTI LS("locati on",,LOC)
  12851   "RTN","VPR DJ05",30,0 )
  12852    . S MED(" orders",1, "locationN ame")=$P(^ SC(LOC,0), U)
  12853   "RTN","VPR DJ05",31,0 )
  12854    D FACILIT Y^VPRUTILS (FAC,"MED" )
  12855   "RTN","VPR DJ05",32,0 )
  12856    S:$G(ORST RT) MED("o verallStar t")=$$JSON DT^VPRUTIL S(ORSTRT)
  12857   "RTN","VPR DJ05",33,0 )
  12858    S:$G(ORST OP) (MED(" stopped"), MED("overa llStop"))= $$JSONDT^V PRUTILS(OR STOP)
  12859   "RTN","VPR DJ05",34,0 )
  12860    S MED("va Status")=$ P($G(ORSTS ),U,2)
  12861   "RTN","VPR DJ05",35,0 )
  12862    S MED("me dStatusNam e")=$$STAT US^VPRDPSO R(+$G(ORST S))
  12863   "RTN","VPR DJ05",36,0 )
  12864    S MED("me dStatus")= $$MEDSTAT^ VPRDJ05V(M ED("medSta tusName"))
  12865   "RTN","VPR DJ05",37,0 )
  12866    I CLS="I"  D
  12867   "RTN","VPR DJ05",38,0 )
  12868    . S:$P($G (^SC(+$G(L OC),0)),U, 25) MED("I MO")="true "
  12869   "RTN","VPR DJ05",39,0 )
  12870    . S X=$P( $G(^OR(100 ,ID,3)),U, 9) S:X MED ("parent") =X
  12871   "RTN","VPR DJ05",40,0 )
  12872    I ORPK D  OEL^PSOORR L(DFN,ORPK _";"_CLS)
  12873   "RTN","VPR DJ05",41,0 )
  12874    S X=$S(OR PK["N":"N" ,1:CLS),ME D("vaType" )=X,MED("m edType")=$ $TYPE^VPRD J05V(X)
  12875   "RTN","VPR DJ05",42,0 )
  12876    I CLS="O"  S MED("ty pe")=$S(OR PK["N":"OT C",1:"Pres cription")
  12877   "RTN","VPR DJ05",43,0 )
  12878    S X=$G(VP RESP("COMM ENT",1)) S :$L(X) MED ("comment" )=X
  12879   "RTN","VPR DJ05",44,0 )
  12880    I $$ISIV^ VPRDJ05V G  IV1^VPRDJ 05V
  12881   "RTN","VPR DJ05",45,0 )
  12882    ;
  12883   "RTN","VPR DJ05",46,0 )
  12884   A ; - Get  order resp onses
  12885   "RTN","VPR DJ05",47,0 )
  12886    S OI=$$OI ^ORX8(ID)  I OI D
  12887   "RTN","VPR DJ05",48,0 )
  12888    . S X=$P( OI,U,2) S: $E(X,$L(X) )=" " X=$E (X,1,$L(X) -1)
  12889   "RTN","VPR DJ05",49,0 )
  12890    . S MED(" name")=X
  12891   "RTN","VPR DJ05",50,0 )
  12892    . D ZERO^ PSS50P7(+$ P(OI,U,3), ,,"PSOI")
  12893   "RTN","VPR DJ05",51,0 )
  12894    . S MED(" productFor mName")=$P ($G(^TMP($ J,"PSOI",+ $P(OI,U,3) ,.02)),U,2 )
  12895   "RTN","VPR DJ05",52,0 )
  12896    . S:+$G(^ TMP($J,"PS OI",+$P(OI ,U,3),.09) ) MED("sup ply")="tru e"
  12897   "RTN","VPR DJ05",53,0 )
  12898    D RESP^VP RDPSOR(ID, .VPRESP) ; order resp onses
  12899   "RTN","VPR DJ05",54,0 )
  12900    S DRUG=+$ G(^TMP("PS ",$J,"DD", 1,0)) S:'D RUG DRUG=+ $G(VPRESP( "DRUG",1))
  12901   "RTN","VPR DJ05",55,0 )
  12902    S MED("si g")=$S(CLS ="I":"Give : ",1:"")_ $G(VPRESP( "SIG",1))  ;ORTX(2)
  12903   "RTN","VPR DJ05",56,0 )
  12904    I CLS="O" ,'$L($G(VP RESP("SIG" ,1))),'$D( VPRESP("IN STR")) S M ED("sig")= $G(VPRESP( "COMMENT", 1)) ;old R x
  12905   "RTN","VPR DJ05",57,0 )
  12906    ;
  12907   "RTN","VPR DJ05",58,0 )
  12908   B ; - Get  dosages
  12909   "RTN","VPR DJ05",59,0 )
  12910    I '$O(^OR (100,ID,2, 0)) D  ;si ngle dose  or OP
  12911   "RTN","VPR DJ05",60,0 )
  12912    . N VPRY, START,STOP ,DUR,CONJ, MIN
  12913   "RTN","VPR DJ05",61,0 )
  12914    . S START =$G(ORSTRT ),STOP=$G( ORSTOP),MI N=0
  12915   "RTN","VPR DJ05",62,0 )
  12916    . S CNT=0  F  S CNT= $O(VPRESP( "INSTR",CN T)) Q:CNT< 1  D
  12917   "RTN","VPR DJ05",63,0 )
  12918    .. K VPRY  D DOSE(.V PRY,CNT) M  MED("dosa ges",CNT)= VPRY
  12919   "RTN","VPR DJ05",64,0 )
  12920    .. ;deter mine start  & stop pe r dose
  12921   "RTN","VPR DJ05",65,0 )
  12922    .. S MED( "dosages", CNT,"relat iveStart") =MIN
  12923   "RTN","VPR DJ05",66,0 )
  12924    .. S DUR= $G(VPRY("c omplexDura tion")),CO NJ=$G(VPRY ("complexC onjunction "))
  12925   "RTN","VPR DJ05",67,0 )
  12926    .. S STOP =$S(DUR:$$ STOP(START ,DUR),1:ST OP)
  12927   "RTN","VPR DJ05",68,0 )
  12928    .. S:STAR T MED("dos ages",CNT, "start")=$ $JSONDT^VP RUTILS(STA RT)
  12929   "RTN","VPR DJ05",69,0 )
  12930    .. S:STOP  MED("dosa ges",CNT," stop")=$$J SONDT^VPRU TILS(STOP)
  12931   "RTN","VPR DJ05",70,0 )
  12932    .. S X=$$ RELTIME(ST ART,STOP,D UR,MIN),ME D("dosages ",CNT,"rel ativeStop" )=$S($E(X) =".":0_X,1 :X)
  12933   "RTN","VPR DJ05",71,0 )
  12934    .. I $E(C ONJ)="T",D UR S START =STOP,MIN= X
  12935   "RTN","VPR DJ05",72,0 )
  12936    I $O(^OR( 100,ID,2,0 )) D
  12937   "RTN","VPR DJ05",73,0 )
  12938    . N DD,CO NJ,VPRY,MI N
  12939   "RTN","VPR DJ05",74,0 )
  12940    . M CONJ= VPRESP("CO NJ"),DUR=V PRESP("DAY S") S MIN= 0
  12941   "RTN","VPR DJ05",75,0 )
  12942    . S (DA,C NT)=0 F  S  DA=$O(^OR (100,ID,2, DA)) Q:DA< 1  D  ;chi ld orders
  12943   "RTN","VPR DJ05",76,0 )
  12944    .. K VPRE SP,VPRY D  RESP^VPRDP SOR(DA,.VP RESP),DOSE (.VPRY,1)
  12945   "RTN","VPR DJ05",77,0 )
  12946    .. S CNT= CNT+1 M ME D("dosages ",CNT)=VPR Y
  12947   "RTN","VPR DJ05",78,0 )
  12948    .. S MED( "dosages", CNT,"relat iveStart") =MIN
  12949   "RTN","VPR DJ05",79,0 )
  12950    .. S MED( "dosages", CNT,"compl exConjunct ion")=$G(C ONJ(CNT))
  12951   "RTN","VPR DJ05",80,0 )
  12952    .. S MED( "dosages", CNT,"compl exDuration ")=$G(DUR( CNT))
  12953   "RTN","VPR DJ05",81,0 )
  12954    .. S MED( "dosages", CNT,"relat edOrder")= DA
  12955   "RTN","VPR DJ05",82,0 )
  12956    .. S X=$P ($G(^OR(10 0,DA,0)),U ,8,9)
  12957   "RTN","VPR DJ05",83,0 )
  12958    .. S:$P(X ,U) MED("d osages",CN T,"start") =$$JSONDT^ VPRUTILS($ P(X,U))
  12959   "RTN","VPR DJ05",84,0 )
  12960    .. S:$P(X ,U,2) MED( "dosages", CNT,"stop" )=$$JSONDT ^VPRUTILS( $P(X,U,2))
  12961   "RTN","VPR DJ05",85,0 )
  12962    .. I $P(X ,U,2)>$G(O RSTOP) S O RSTOP=$P(X ,U,2) ;get  last stop  time
  12963   "RTN","VPR DJ05",86,0 )
  12964    .. S X=$$ RELTIME($P (X,U),$P(X ,U,2),$G(D UR(CNT)),M IN)
  12965   "RTN","VPR DJ05",87,0 )
  12966    .. S MED( "dosages", CNT,"relat iveStop")= $S($E(X)=" .":0_X,1:X ) S:$G(CON J(CNT))="T " MIN=X
  12967   "RTN","VPR DJ05",88,0 )
  12968    .. S:'DRU G DD=+$G(V PRESP("DRU G",1)),DD( DD,DA)=""  ;dispense  drug(s)
  12969   "RTN","VPR DJ05",89,0 )
  12970    .. ; get  ^TMP("PS", $J) from 1 st child,  if Inpt pa rent:
  12971   "RTN","VPR DJ05",90,0 )
  12972    .. I '$D( ^TMP("PS", $J)) S ORP K=$$PKGID^ ORX8(DA) D  OEL^PSOOR RL(DFN,ORP K_";"_CLS)
  12973   "RTN","VPR DJ05",91,0 )
  12974    . S MED(" stopped")= $$JSONDT^V PRUTILS($G (ORSTOP))  ;reset fro m last chi ld order
  12975   "RTN","VPR DJ05",92,0 )
  12976    . S DD=$O (DD(0)) I  DD,'$O(DD( DD)) S DRU G=DD Q     ;1 drug fo r order
  12977   "RTN","VPR DJ05",93,0 )
  12978    . S (DD,C NT)=0 F  S  DD=$O(DD( DD)) Q:DD< 1  S DA=0  F  S DA=$O (DD(DD,DA) ) Q:DA<1   S CNT=CNT+ 1 D NDF(DD ,CNT,DA)
  12979   "RTN","VPR DJ05",94,0 )
  12980    ;
  12981   "RTN","VPR DJ05",95,0 )
  12982   C ; - Get  OP data
  12983   "RTN","VPR DJ05",96,0 )
  12984    I CLS="O" ,ORPK'["N"  D
  12985   "RTN","VPR DJ05",97,0 )
  12986    . S MED(" orders",1, "quantityO rdered")=$ G(VPRESP(" QTY",1))
  12987   "RTN","VPR DJ05",98,0 )
  12988    . S MED(" orders",1, "daysSuppl y")=$G(VPR ESP("SUPPL Y",1))
  12989   "RTN","VPR DJ05",99,0 )
  12990    . S MED(" orders",1, "vaRouting ")=$G(VPRE SP("PICKUP ",1))
  12991   "RTN","VPR DJ05",100, 0)
  12992    . S MED(" orders",1, "fillsAllo wed")=$G(V PRESP("REF ILLS",1))
  12993   "RTN","VPR DJ05",101, 0)
  12994    . S MED(" patientIns truction") =$G(VPRESP ("PI",1))
  12995   "RTN","VPR DJ05",102, 0)
  12996    . Q:ORPK[ "P"!(ORPK[ "S")  ;pen ding
  12997   "RTN","VPR DJ05",103, 0)
  12998    . N VPR,R X0,RX1,FIL L,RFD,MW,R EL
  12999   "RTN","VPR DJ05",104, 0)
  13000    . K ^TMP( "PSOR",$J)  D EN^PSOO RDER(DFN,+ ORPK)
  13001   "RTN","VPR DJ05",105, 0)
  13002    . S RX0=$ G(^TMP("PS OR",$J,+OR PK,0)),RX1 =$G(^(1)), MED("order s",1,"pres criptionId ")=$P(RX0, U,5)
  13003   "RTN","VPR DJ05",106, 0)
  13004    . I '$G(V PRESP("QTY ",1)) S ME D("orders" ,1,"quanti tyOrdered" )=$P(RX0,U ,6)
  13005   "RTN","VPR DJ05",107, 0)
  13006    . I '$G(V PRESP("SUP PLY",1)) S  MED("orde rs",1,"day sSupply")= $P(RX0,U,7 )
  13007   "RTN","VPR DJ05",108, 0)
  13008    . S MED(" orders",1, "fillsRema ining")=$P (RX0,U,9), MED("lastF illed")=$$ JSONDT^VPR UTILS($P(R X0,U,3))
  13009   "RTN","VPR DJ05",109, 0)
  13010    . S I=$P( RX0,U,2) I  I S FILL( I)=I_"^^^" _$P(RX0,U, 6,7)_"^^^" _$P(RX0,U, 13)_"^^"_$ P(RX1,U,6)  ;original  fill
  13011   "RTN","VPR DJ05",110, 0)
  13012    . S I=0 F   S I=$O(^ TMP("PSOR" ,$J,+ORPK, "REF",I))  Q:I<1  S X =$G(^(I,0) ),FILL(+X) =X
  13013   "RTN","VPR DJ05",111, 0)
  13014    . S I=0 F   S I=$O(^ TMP("PSOR" ,$J,+ORPK, "RPAR",I))  Q:I<1  S  X=$G(^(I,0 )),$P(X,U, 14)=1,FILL (+X)=X
  13015   "RTN","VPR DJ05",112, 0)
  13016    . S (I,RF D)=0 F  S  RFD=$O(FIL L(RFD)) Q: RFD<1  S X =$G(FILL(R FD)) D  ;s ort 1st
  13017   "RTN","VPR DJ05",113, 0)
  13018    .. S I=I+ 1,MW=$P($P (X,U,10)," ;"),REL=$P ($P(X,U,8) ,".")
  13019   "RTN","VPR DJ05",114, 0)
  13020    .. S MED( "fills",I, "dispenseD ate")=$$JS ONDT^VPRUT ILS($P(RFD ,"."))
  13021   "RTN","VPR DJ05",115, 0)
  13022    .. S MED( "fills",I, "releaseDa te")=$$JSO NDT^VPRUTI LS(REL)
  13023   "RTN","VPR DJ05",116, 0)
  13024    .. S MED( "fills",I, "routing") =MW
  13025   "RTN","VPR DJ05",117, 0)
  13026    .. S MED( "fills",I, "quantityD ispensed") =$P(X,U,4)
  13027   "RTN","VPR DJ05",118, 0)
  13028    .. S MED( "fills",I, "daysSuppl yDispensed ")=$P(X,U, 5)
  13029   "RTN","VPR DJ05",119, 0)
  13030    .. S:$P(X ,U,14) MED ("fills",I ,"partial" )=1 ;"true "
  13031   "RTN","VPR DJ05",120, 0)
  13032    . S X=$S( $P(RX0,U,1 1):$P(RX0, U,11),$P(R X0,U,10):$ P(RX0,U,10 ),1:0)
  13033   "RTN","VPR DJ05",121, 0)
  13034    . S:X MED ("orders", 1,"fillCos t")=X
  13035   "RTN","VPR DJ05",122, 0)
  13036    . S X=$$G ET1^PSODI( 52,+ORPK_" ,",26,"I")  S:X MED(" overallSto p")=$$JSON DT^VPRUTIL S($P(X,U,2 )) ;1^expi rationDate
  13037   "RTN","VPR DJ05",123, 0)
  13038    I CLS="I"  D
  13039   "RTN","VPR DJ05",124, 0)
  13040    . S X=$$G ET1^DIQ(55 .06,+ORPK_ ","_DFN_", ",25,"I")
  13041   "RTN","VPR DJ05",125, 0)
  13042    . S:X MED ("overallS top")=$$JS ONDT^VPRUT ILS(X)
  13043   "RTN","VPR DJ05",126, 0)
  13044    . D BCMA^ VPRDJ05V(. MED,DFN,OR PK)
  13045   "RTN","VPR DJ05",127, 0)
  13046    ;
  13047   "RTN","VPR DJ05",128, 0)
  13048   PSQ ; fini sh
  13049   "RTN","VPR DJ05",129, 0)
  13050    D:DRUG ND F(+DRUG)
  13051   "RTN","VPR DJ05",130, 0)
  13052    S MED("qu alifiedNam e")=$G(MED ("name"))
  13053   "RTN","VPR DJ05",131, 0)
  13054    S X=+$P($ G(^TMP("PS ",$J,"RXN" ,0)),U,5)
  13055   "RTN","VPR DJ05",132, 0)
  13056    S:X MED(" orders",1, "pharmacis tUid")=$$S ETUID^VPRU TILS("user ",,X),MED( "orders",1 ,"pharmaci stName")=$ P($G(^VA(2 00,X,0)),U )
  13057   "RTN","VPR DJ05",133, 0)
  13058    K ^TMP("P S",$J),^TM P($J,"PSOI "),^TMP("P SOR",$J)
  13059   "RTN","VPR DJ05",134, 0)
  13060    D ADD^VPR DJ("MED"," med")
  13061   "RTN","VPR DJ05",135, 0)
  13062    Q
  13063   "RTN","VPR DJ05",136, 0)
  13064    ;
  13065   "RTN","VPR DJ05",137, 0)
  13066   DOSE(Y,N)  ; -- retur n dosage d ata from V PRESP(ID,N ) to Y("na me")
  13067   "RTN","VPR DJ05",138, 0)
  13068    N X,DUR,C ONJ S N=+$ G(N,1) K Y
  13069   "RTN","VPR DJ05",139, 0)
  13070    S X=$P($G (VPRESP("D OSE",N))," &",1,2) ;  units per  dose + nou n
  13071   "RTN","VPR DJ05",140, 0)
  13072    S Y("dose ")=$S($L(X )>2:$TR(X, "&"," "),1 :$P(X,"&") )
  13073   "RTN","VPR DJ05",141, 0)
  13074    S Y("unit s")=$P(X," &",2)
  13075   "RTN","VPR DJ05",142, 0)
  13076    S X=+$G(V PRESP("ROU TE",N)) D  ALL^PSS51P 2(X,,,,"VP RTE")
  13077   "RTN","VPR DJ05",143, 0)
  13078    S Y("rout eName")=$G (^TMP($J," VPRTE",X,1 ))
  13079   "RTN","VPR DJ05",144, 0)
  13080    S X=$G(VP RESP("SCHE DULE",N))  I $L(X) S  Y("schedul eName")=X  D SCH^VPRD J05V(X)
  13081   "RTN","VPR DJ05",145, 0)
  13082    S X=$G(VP RESP("ADMI N",N)) S:$ L(X) Y("ad minTimes") =X
  13083   "RTN","VPR DJ05",146, 0)
  13084    S X=$G(VP RESP("DAYS ",N)) S:$L (X) Y("com plexDurati on")=X,DUR =X
  13085   "RTN","VPR DJ05",147, 0)
  13086    S X=$G(VP RESP("CONJ ",N)) S:$L (X) Y("com plexConjun ction")=X, CONJ=X
  13087   "RTN","VPR DJ05",148, 0)
  13088    I $L($G(C ONJ)),'$L( $G(DUR)) D   ;look ah ead to fin d duration
  13089   "RTN","VPR DJ05",149, 0)
  13090    . N I,D S  I=$O(VPRE SP("DAYS", N)),D=$S(I :$G(VPRESP ("DAYS",I) ),1:"")
  13091   "RTN","VPR DJ05",150, 0)
  13092    . S:$L(D)  Y("comple xDuration" )=D
  13093   "RTN","VPR DJ05",151, 0)
  13094    K ^TMP($J ,"VPRTE")
  13095   "RTN","VPR DJ05",152, 0)
  13096    Q
  13097   "RTN","VPR DJ05",153, 0)
  13098    ;
  13099   "RTN","VPR DJ05",154, 0)
  13100   STOP(BEG,X ) ; -- Ret urn date a fter addin g X to BEG
  13101   "RTN","VPR DJ05",155, 0)
  13102    N D,H,M,U NT,Y
  13103   "RTN","VPR DJ05",156, 0)
  13104    S Y=BEG,( D,H,M)=0,U NT=$P(X,+X ,2),X=+X
  13105   "RTN","VPR DJ05",157, 0)
  13106    S UNT=$S( $E(UNT)="  ":$E(UNT,2 ),1:$E(UNT )) I UNT=" " S UNT="D "
  13107   "RTN","VPR DJ05",158, 0)
  13108    S:UNT="L"  D=30*X
  13109   "RTN","VPR DJ05",159, 0)
  13110    S:UNT="W"  D=7*X
  13111   "RTN","VPR DJ05",160, 0)
  13112    S:UNT="D"  D=X
  13113   "RTN","VPR DJ05",161, 0)
  13114    S:UNT="H"  H=X
  13115   "RTN","VPR DJ05",162, 0)
  13116    S:UNT="M"  M=X
  13117   "RTN","VPR DJ05",163, 0)
  13118    S Y=$$FMA DD^XLFDT(B EG,D,H,M)
  13119   "RTN","VPR DJ05",164, 0)
  13120    Q Y
  13121   "RTN","VPR DJ05",165, 0)
  13122    ;
  13123   "RTN","VPR DJ05",166, 0)
  13124   NDF(DRUG,V PI,ORD) ;  -- Set NDF  data for  dispense D RUG ien
  13125   "RTN","VPR DJ05",167, 0)
  13126    ; code ^  name ^ vui d [^ role  ^ concentr ation ^ or der]
  13127   "RTN","VPR DJ05",168, 0)
  13128    N LEN,VPR X,STR,VUID ,X,I
  13129   "RTN","VPR DJ05",169, 0)
  13130    S DRUG=+$ G(DRUG) Q: 'DRUG
  13131   "RTN","VPR DJ05",170, 0)
  13132    D EN^PSSD I(50,,50," 901;902",D RUG,"VPRX" )
  13133   "RTN","VPR DJ05",171, 0)
  13134    S STR=$S( $G(VPRX(50 ,DRUG,901) ):$G(VPRX( 50,DRUG,90 1))_" "_$G (VPRX(50,D RUG,902)), 1:"")
  13135   "RTN","VPR DJ05",172, 0)
  13136    D NDF^PSS 50(DRUG,,, ,,"NDF") S  VPI=+$G(V PI,1)
  13137   "RTN","VPR DJ05",173, 0)
  13138    ;
  13139   "RTN","VPR DJ05",174, 0)
  13140    S MED("pr oducts",VP I,"ingredi entRole")= "urn:sct:4 10942007"  ;Drug
  13141   "RTN","VPR DJ05",175, 0)
  13142    S:$G(ORD)  MED("prod ucts",VPI, "relatedOr der")=ORD
  13143   "RTN","VPR DJ05",176, 0)
  13144    S:$G(STR)  MED("prod ucts",VPI, "strength" )=STR
  13145   "RTN","VPR DJ05",177, 0)
  13146    S X=$G(ME D("name"))  S:$L(X) M ED("produc ts",VPI,"i ngredientN ame")=X
  13147   "RTN","VPR DJ05",178, 0)
  13148    ;
  13149   "RTN","VPR DJ05",179, 0)
  13150    S X=$G(^T MP($J,"NDF ",DRUG,20) ) ;VA Gene ric
  13151   "RTN","VPR DJ05",180, 0)
  13152    S MED("pr oducts",VP I,"ingredi entCode")= "urn:va:vu id:"_$$VUI D^VPRD(+X, 50.6)
  13153   "RTN","VPR DJ05",181, 0)
  13154    S MED("pr oducts",VP I,"ingredi entCodeNam e")=$P(X,U ,2)
  13155   "RTN","VPR DJ05",182, 0)
  13156    ;
  13157   "RTN","VPR DJ05",183, 0)
  13158    S X=$G(^T MP($J,"NDF ",DRUG,22) ) ;VA Prod uct
  13159   "RTN","VPR DJ05",184, 0)
  13160    S MED("pr oducts",VP I,"supplie dCode")="u rn:va:vuid :"_$$VUID^ VPRD(+X,50 .68)
  13161   "RTN","VPR DJ05",185, 0)
  13162    S MED("pr oducts",VP I,"supplie dName")=$P (X,U,2)
  13163   "RTN","VPR DJ05",186, 0)
  13164    ;
  13165   "RTN","VPR DJ05",187, 0)
  13166    S X=$G(^T MP($J,"NDF ",DRUG,25) ) ;VA Drug  Class
  13167   "RTN","VPR DJ05",188, 0)
  13168    S MED("pr oducts",VP I,"drugCla ssCode")=" urn:vadc:" _$P(X,U,2)
  13169   "RTN","VPR DJ05",189, 0)
  13170    S MED("pr oducts",VP I,"drugCla ssName")=$ P(X,U,3)
  13171   "RTN","VPR DJ05",190, 0)
  13172    ;
  13173   "RTN","VPR DJ05",191, 0)
  13174    K ^TMP($J ,"NDF")
  13175   "RTN","VPR DJ05",192, 0)
  13176    Q
  13177   "RTN","VPR DJ05",193, 0)
  13178    ;
  13179   "RTN","VPR DJ05",194, 0)
  13180   RELTIME(ST ART,STOP,D UR,MIN) ;  -- Return  #min for d ose
  13181   "RTN","VPR DJ05",195, 0)
  13182    N Y S Y=0
  13183   "RTN","VPR DJ05",196, 0)
  13184    I START>0 ,STOP>0 S  Y=$$FMDIFF ^XLFDT(STO P,START,2) \60 I 1
  13185   "RTN","VPR DJ05",197, 0)
  13186    E  I DUR  S Y=$$TOMI N(DUR) I 1
  13187   "RTN","VPR DJ05",198, 0)
  13188    E  S Y=$G (VPRESP("S UPPLY",1)) *1440
  13189   "RTN","VPR DJ05",199, 0)
  13190    S Y=$S(Y: Y+MIN,1:MI N)
  13191   "RTN","VPR DJ05",200, 0)
  13192    Q Y
  13193   "RTN","VPR DJ05",201, 0)
  13194    ;
  13195   "RTN","VPR DJ05",202, 0)
  13196   TOMIN(DUR)  ;
  13197   "RTN","VPR DJ05",203, 0)
  13198    N RESULT, TIME,UNIT
  13199   "RTN","VPR DJ05",204, 0)
  13200    S UNIT=$$ UP^XLFSTR( $E($P(DUR, " ",2)))
  13201   "RTN","VPR DJ05",205, 0)
  13202    I UNIT=""  Q 0
  13203   "RTN","VPR DJ05",206, 0)
  13204    S TIME=$P (DUR," ")
  13205   "RTN","VPR DJ05",207, 0)
  13206    S RESULT= $S(UNIT="M ":TIME,UNI T="H":TIME *60,UNIT=" D":TIME*14 40,UNIT="W ":TIME*100 80,UNIT="L ":TIME*432 00,1:0)
  13207   "RTN","VPR DJ05",208, 0)
  13208    Q RESULT
  13209   "RTN","VPR DJ06")
  13210   0^77^B5892 7484
  13211   "RTN","VPR DJ06",1,0)
  13212   VPRDJ06 ;S LC/MKB --  Laboratory  ;6/25/12   16:11
  13213   "RTN","VPR DJ06",2,0)
  13214    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  13215   "RTN","VPR DJ06",3,0)
  13216    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  13217   "RTN","VPR DJ06",4,0)
  13218    ;
  13219   "RTN","VPR DJ06",5,0)
  13220    ; Externa l Referenc es           DBIA#
  13221   "RTN","VPR DJ06",6,0)
  13222    ; ------- ---------- --           -----
  13223   "RTN","VPR DJ06",7,0)
  13224    ; ^LAB(60                         10054
  13225   "RTN","VPR DJ06",8,0)
  13226    ; ^LR                               525
  13227   "RTN","VPR DJ06",9,0)
  13228    ; ^PXRMIN DX                       4290
  13229   "RTN","VPR DJ06",10,0 )
  13230    ; ^TMP("L RRR" [LR7O R1]           2503
  13231   "RTN","VPR DJ06",11,0 )
  13232    ; DIQ                              2056
  13233   "RTN","VPR DJ06",12,0 )
  13234    ; LR7OR1, ^TMP("LRRR "             2503
  13235   "RTN","VPR DJ06",13,0 )
  13236    ; LRPXAPI                          4245
  13237   "RTN","VPR DJ06",14,0 )
  13238    ; LRPXAPI U                        4246
  13239   "RTN","VPR DJ06",15,0 )
  13240    ; XLFSTR                          10104
  13241   "RTN","VPR DJ06",16,0 )
  13242    ; XUAF4                            2171
  13243   "RTN","VPR DJ06",17,0 )
  13244    ;
  13245   "RTN","VPR DJ06",18,0 )
  13246    ; All tag s expect D FN, ID, LR DFN, [VPRS TART, VPRS TOP, VPRMA X, VPRTEXT ]
  13247   "RTN","VPR DJ06",19,0 )
  13248    ;                & ^ TMP("LRRR" ,$J,DFN,VP RSUB,VPRID T,VPRP),VP RN
  13249   "RTN","VPR DJ06",20,0 )
  13250    ;
  13251   "RTN","VPR DJ06",21,0 )
  13252   CH1 ; -- l ab ID = CH ;VPRIDT;VP RN
  13253   "RTN","VPR DJ06",22,0 )
  13254    N LAB,LRI ,X,X0,SPC, LOINC,ORD, CMMT
  13255   "RTN","VPR DJ06",23,0 )
  13256    N $ES,$ET ,ERRPAT,ER RMSG
  13257   "RTN","VPR DJ06",24,0 )
  13258    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  13259   "RTN","VPR DJ06",25,0 )
  13260    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he chemist ry domain"
  13261   "RTN","VPR DJ06",26,0 )
  13262    ;
  13263   "RTN","VPR DJ06",27,0 )
  13264    M LAB=VPR ACC ;get a ccession i nfo
  13265   "RTN","VPR DJ06",28,0 )
  13266    S LAB("lo calId")=ID ,LAB("uid" )=$$SETUID ^VPRUTILS( "lab",DFN, ID)
  13267   "RTN","VPR DJ06",29,0 )
  13268    S LAB("ca tegoryCode ")="urn:va :lab-categ ory:CH"
  13269   "RTN","VPR DJ06",30,0 )
  13270    S LAB("ca tegoryName ")="Labora tory"
  13271   "RTN","VPR DJ06",31,0 )
  13272    S LAB("di splayOrder ")=VPRP
  13273   "RTN","VPR DJ06",32,0 )
  13274    S LRI=$G( ^LR(LRDFN, "CH",VPRID T,VPRN))
  13275   "RTN","VPR DJ06",33,0 )
  13276    S X0=$G(^ TMP("LRRR" ,$J,DFN,"C H",VPRIDT, VPRP)),SPC =+$P(X0,U, 19)
  13277   "RTN","VPR DJ06",34,0 )
  13278    S LAB("ty peId")=+X0 ,LAB("type Name")=$P( $G(^LAB(60 ,+X0,0)),U )
  13279   "RTN","VPR DJ06",35,0 )
  13280    S:$L($P(X 0,U,2)) LA B("result" )=$P(X0,U, 2)
  13281   "RTN","VPR DJ06",36,0 )
  13282    S:$L($P(X 0,U,4)) LA B("units") =$P(X0,U,4 )
  13283   "RTN","VPR DJ06",37,0 )
  13284    S X=$P(X0 ,U,5) I $L (X),X["-"  S LAB("low ")=$$TRIM^ XLFSTR($P( X,"-")),LA B("high")= $$TRIM^XLF STR($P(X," -",2))
  13285   "RTN","VPR DJ06",38,0 )
  13286    S X=$P(X0 ,U,3) I $L (X) D
  13287   "RTN","VPR DJ06",39,0 )
  13288    . S:X["*"  X=$S(X["L ":"LL",1:" HH")
  13289   "RTN","VPR DJ06",40,0 )
  13290    . S LAB(" interpreta tionCode") ="urn:hl7: observatio n-interpre tation:"_X
  13291   "RTN","VPR DJ06",41,0 )
  13292    . S LAB(" interpreta tionName") =$S(X["L": "Low",1:"H igh")_$S($ L(X)>1:" a lert",1:"" )
  13293   "RTN","VPR DJ06",42,0 )
  13294    S LAB("di splayName" )=$S($L($P (X0,U,15)) :$P(X0,U,1 5),1:LAB(" test"))
  13295   "RTN","VPR DJ06",43,0 )
  13296    S ORD=+$P (X0,U,17)  S:ORD LAB( "labOrderI d")=ORD
  13297   "RTN","VPR DJ06",44,0 )
  13298    S X=$$ORD ER^VPRDLR( ORD,+X0) S :X LAB("or derUid")=$ $SETUID^VP RUTILS("or der",DFN,X )
  13299   "RTN","VPR DJ06",45,0 )
  13300    S LOINC=$ P($P(LRI,U ,3),"!",3)  S:'LOINC  LOINC=$$LO INC(+X0,SP C)
  13301   "RTN","VPR DJ06",46,0 )
  13302    I LOINC S  LAB("type Code")="ur n:lnc:"_$$ GET1^DIQ(9 5.3,+LOINC _",",.01), LAB("vuid" )="urn:va: vuid:"_$$V UID^VPRD(+ LOINC,95.3 )
  13303   "RTN","VPR DJ06",47,0 )
  13304    I 'LOINC  S LAB("typ eCode")="u rn:va:ien: 60:"_+X0_" :"_SPC
  13305   "RTN","VPR DJ06",48,0 )
  13306    I $D(^TMP ("LRRR",$J ,DFN,"CH", VPRIDT,"N" )) M CMMT= ^("N") S L AB("commen t")=$$STRI NG^VPRD(.C MMT)
  13307   "RTN","VPR DJ06",49,0 )
  13308    S LAB("st atusCode") ="urn:va:l ab-status: completed" ,LAB("stat usName")=" completed"
  13309   "RTN","VPR DJ06",50,0 )
  13310    D ADD^VPR DJ("LAB"," lab")
  13311   "RTN","VPR DJ06",51,0 )
  13312    Q
  13313   "RTN","VPR DJ06",52,0 )
  13314    ;
  13315   "RTN","VPR DJ06",53,0 )
  13316   LOINC(TEST ,SPEC) ; - - find LOI NC ien, if  not saved  with resu lt [for DE V only]
  13317   "RTN","VPR DJ06",54,0 )
  13318    N Y,X,LAM ,I S Y=""
  13319   "RTN","VPR DJ06",55,0 )
  13320    I '$G(TES T)!'$G(SPE C) Q ""
  13321   "RTN","VPR DJ06",56,0 )
  13322    S Y=+$G(^ LAB(60,TES T,1,SPEC,9 5.3)) I 'Y  D
  13323   "RTN","VPR DJ06",57,0 )
  13324    . S LAM=$ G(^LAB(60, TEST,64)), X=$S($P(LA M,U,2):$P( LAM,U,2),L AM:+LAM,1: "") Q:'X
  13325   "RTN","VPR DJ06",58,0 )
  13326    . S I=+$O (^LAM(X,5, SPEC,1,0)) ,Y=+$P($G( ^(I,1)),U)  Q:Y  ;fir st, node 1
  13327   "RTN","VPR DJ06",59,0 )
  13328    . S Y=$P( $G(^LAM(X, 9)),U) ;de fault LOIN C
  13329   "RTN","VPR DJ06",60,0 )
  13330    Q Y
  13331   "RTN","VPR DJ06",61,0 )
  13332    ;
  13333   "RTN","VPR DJ06",62,0 )
  13334   ACC ; -- p ut accessi on-level d ata in VPR ACC("attri bute")
  13335   "RTN","VPR DJ06",63,0 )
  13336    N LR0,CDT ,SPC,X K V PRACC
  13337   "RTN","VPR DJ06",64,0 )
  13338    S LR0=$G( ^LR(LRDFN, VPRSUB,VPR IDT,0))
  13339   "RTN","VPR DJ06",65,0 )
  13340    S CDT=999 9999-VPRID T,VPRACC(" observed") =$$DATE(CD T)
  13341   "RTN","VPR DJ06",66,0 )
  13342    S VPRACC( "resulted" )=$$DATE($ P(LR0,U,3) ),SPC=+$P( LR0,U,5) I  SPC D
  13343   "RTN","VPR DJ06",67,0 )
  13344    . N IENS, VPRY S IEN S=SPC_","
  13345   "RTN","VPR DJ06",68,0 )
  13346    . D GETS^ DIQ(61,IEN S,".01;4.1 ",,"VPRY")
  13347   "RTN","VPR DJ06",69,0 )
  13348    . S VPRAC C("specime n")=$G(VPR Y(61,IENS, .01))
  13349   "RTN","VPR DJ06",70,0 )
  13350    . S VPRAC C("sample" )=$G(VPRY( 61,IENS,4. 1))
  13351   "RTN","VPR DJ06",71,0 )
  13352    S VPRACC( "groupUid" )=$$SETUID ^VPRUTILS( "accession ",DFN,VPRS UB_";"_VPR IDT)
  13353   "RTN","VPR DJ06",72,0 )
  13354    S VPRACC( "groupName ")=$P(LR0, U,6)
  13355   "RTN","VPR DJ06",73,0 )
  13356    S X=+$P(L R0,U,14) D   D FACILI TY^VPRUTIL S(X,"VPRAC C")
  13357   "RTN","VPR DJ06",74,0 )
  13358    . S:X X=$ $STA^XUAF4 (X)_U_$P($ $NS^XUAF4( X),U)
  13359   "RTN","VPR DJ06",75,0 )
  13360    . I 'X S  X=$$FAC^VP RD ;local  stn#^name
  13361   "RTN","VPR DJ06",76,0 )
  13362    Q
  13363   "RTN","VPR DJ06",77,0 )
  13364    ;
  13365   "RTN","VPR DJ06",78,0 )
  13366   MI ; -- mi crobiology  accession  ID = MI;V PRIDT
  13367   "RTN","VPR DJ06",79,0 )
  13368    N LAB,CDT ,LR0,X,ACC ,FAC,X0,X1 ,X2,IDX,VP RM,VPRPX,V PRITM,DA,F LD
  13369   "RTN","VPR DJ06",80,0 )
  13370    N $ES,$ET ,ERRPAT,ER RMSG
  13371   "RTN","VPR DJ06",81,0 )
  13372    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  13373   "RTN","VPR DJ06",82,0 )
  13374    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he microbi ology doma in"
  13375   "RTN","VPR DJ06",83,0 )
  13376    ;
  13377   "RTN","VPR DJ06",84,0 )
  13378    S LAB("lo calId")=ID ,LAB("uid" )=$$SETUID ^VPRUTILS( "lab",DFN, ID)
  13379   "RTN","VPR DJ06",85,0 )
  13380    S LAB("ca tegoryCode ")="urn:va :lab-categ ory:MI"
  13381   "RTN","VPR DJ06",86,0 )
  13382    S LAB("ca tegoryName ")="Microb iology"
  13383   "RTN","VPR DJ06",87,0 )
  13384    S LAB("st atusCode") ="urn:va:l ab-status: completed" ,LAB("stat usName")=" completed"
  13385   "RTN","VPR DJ06",88,0 )
  13386    S CDT=999 9999-VPRID T,LAB("obs erved")=$$ DATE(CDT)
  13387   "RTN","VPR DJ06",89,0 )
  13388    S LR0=$G( ^LR(LRDFN, "MI",VPRID T,0))
  13389   "RTN","VPR DJ06",90,0 )
  13390    S:$P(LR0, U,3) LAB(" resulted") =$$DATE($P (LR0,U,3))
  13391   "RTN","VPR DJ06",91,0 )
  13392    S X=+$P(L R0,U,5) I  X D  ;spec imen
  13393   "RTN","VPR DJ06",92,0 )
  13394    . N IENS, VPRY S IEN S=X_","
  13395   "RTN","VPR DJ06",93,0 )
  13396    . D GETS^ DIQ(61,IEN S,".01;2", ,"VPRY")
  13397   "RTN","VPR DJ06",94,0 )
  13398    . S LAB(" specimen") =$G(VPRY(6 1,IENS,.01 ))
  13399   "RTN","VPR DJ06",95,0 )
  13400    . S LAB(" sample")=$ $GET1^DIQ( 61,X_",",4 .1)
  13401   "RTN","VPR DJ06",96,0 )
  13402    S LAB("gr oupName")= $P(LR0,U,6 ),ACC=$P(I D,";",1,2)  ;accessio n#
  13403   "RTN","VPR DJ06",97,0 )
  13404    S LAB("gr oupUid")=$ $SETUID^VP RUTILS("ac cession",D FN,ACC)
  13405   "RTN","VPR DJ06",98,0 )
  13406    S X=$P(LR 0,U,14),FA C=$S(X:$$S TA^XUAF4(X )_U_$P($$N S^XUAF4(X) ,U),1:$$FA C^VPRD)
  13407   "RTN","VPR DJ06",99,0 )
  13408    D FACILIT Y^VPRUTILS (FAC,"LAB" )
  13409   "RTN","VPR DJ06",100, 0)
  13410    ; get res ults from  ^TMP
  13411   "RTN","VPR DJ06",101, 0)
  13412    S VPRN=0  F  S VPRN= $O(^TMP("L RRR",$J,DF N,VPRSUB,V PRIDT,VPRN )) Q:VPRN< 1  D
  13413   "RTN","VPR DJ06",102, 0)
  13414    . S X0=$G (^TMP("LRR R",$J,DFN, "MI",VPRID T,VPRN)),X 1=$P(X0,U) ,X2=$P(X0, U,2)
  13415   "RTN","VPR DJ06",103, 0)
  13416    . I X1="U RINE SCREE N" S LAB(" urineScree n")=X2 Q
  13417   "RTN","VPR DJ06",104, 0)
  13418    . ; X1="O RGANISM" S  LAB("orga nism")=$P( X2,";"),LA B("organis mQty")=$P( X2,";",2)
  13419   "RTN","VPR DJ06",105, 0)
  13420    . I X1="G RAM STAIN"  S LAB("gr amStain",V PRN,"resul t")=X2 Q
  13421   "RTN","VPR DJ06",106, 0)
  13422    . I X1="B acteriolog y Remark(s )" S LAB(" bactRemark s")=X2 Q
  13423   "RTN","VPR DJ06",107, 0)
  13424    ; get oth er results  from ^PXR MINDX
  13425   "RTN","VPR DJ06",108, 0)
  13426    S X=$O(^P XRMINDX(63 ,"PDI",DFN ,CDT,"M;T; 0")) I X?1 "M;T;"1.N  D
  13427   "RTN","VPR DJ06",109, 0)
  13428    . S IDX=$ O(^PXRMIND X(63,"PDI" ,DFN,CDT,X ,"")) K VP RM
  13429   "RTN","VPR DJ06",110, 0)
  13430    . D LRPXR M^LRPXAPI( .VPRM,IDX, X) Q:VPRM< 1
  13431   "RTN","VPR DJ06",111, 0)
  13432    . S LAB(" typeName") =$P(VPRM,U ,2)
  13433   "RTN","VPR DJ06",112, 0)
  13434    . S LAB(" typeCode") ="urn:va:i en:60:"_+V PRM_":"_+$ P(VPRM,U,7 )
  13435   "RTN","VPR DJ06",113, 0)
  13436    F VPRPX=" M;O;","M;A ;" D
  13437   "RTN","VPR DJ06",114, 0)
  13438    . S VPRIT M=VPRPX F   S VPRITM= $O(^PXRMIN DX(63,"PDI ",DFN,CDT, VPRITM)) Q :$E(VPRITM ,1,4)'=VPR PX  D
  13439   "RTN","VPR DJ06",115, 0)
  13440    .. S IDX= $O(^PXRMIN DX(63,"PDI ",DFN,CDT, VPRITM,"") ) K VPRM
  13441   "RTN","VPR DJ06",116, 0)
  13442    .. S DA=$ P(IDX,";", 5),FLD=$P( IDX,";",6)
  13443   "RTN","VPR DJ06",117, 0)
  13444    .. D LRPX RM^LRPXAPI (.VPRM,IDX ,VPRITM) Q :'$L($G(VP RM))
  13445   "RTN","VPR DJ06",118, 0)
  13446    .. I VPRP X["O" S LA B("organis ms",DA,"na me")=$P(VP RM,U,2),LA B("organis ms",DA,"qt y")=$P(VPR M,U,4) Q
  13447   "RTN","VPR DJ06",119, 0)
  13448    .. I VPRP X["A" D  Q
  13449   "RTN","VPR DJ06",120, 0)
  13450    ... S LAB ("organism s",DA,"dru gs",FLD,"n ame")=$P(V PRM,U,2)
  13451   "RTN","VPR DJ06",121, 0)
  13452    ... S LAB ("organism s",DA,"dru gs",FLD,"r esult")=$P (VPRM,U,3)
  13453   "RTN","VPR DJ06",122, 0)
  13454    ... S LAB ("organism s",DA,"dru gs",FLD,"i nterp")=$P (VPRM,U,4)
  13455   "RTN","VPR DJ06",123, 0)
  13456    ... S:$L( $P(VPRM,U, 5)) LAB("o rganisms", DA,"drugs" ,FLD,"rest rict")=$P( VPRM,U,5)
  13457   "RTN","VPR DJ06",124, 0)
  13458    ;
  13459   "RTN","VPR DJ06",125, 0)
  13460    S LAB("re sults",1," uid")=ACC
  13461   "RTN","VPR DJ06",126, 0)
  13462    S LAB("re sults",1," resultUid" )=$$SETUID ^VPRUTILS( "document" ,DFN,ACC)
  13463   "RTN","VPR DJ06",127, 0)
  13464    S LAB("re sults",1," localTitle ")="LR MIC ROBIOLOGY  REPORT"
  13465   "RTN","VPR DJ06",128, 0)
  13466    I $L($G(^ LR(LRDFN," MI",VPRIDT ,99))) S L AB("commen t")=^(99)
  13467   "RTN","VPR DJ06",129, 0)
  13468    D ADD^VPR DJ("LAB"," lab")
  13469   "RTN","VPR DJ06",130, 0)
  13470    Q
  13471   "RTN","VPR DJ06",131, 0)
  13472    ;
  13473   "RTN","VPR DJ06",132, 0)
  13474   ITEM() ; - - find ITE M string f rom ^PXRMI NDX [uses  LRDFN,ID,D FN,CDT]
  13475   "RTN","VPR DJ06",133, 0)
  13476    N ITM,IDX ,Y S Y=""
  13477   "RTN","VPR DJ06",134, 0)
  13478    S IDX=LRD FN_";"_ID, ITM="M"
  13479   "RTN","VPR DJ06",135, 0)
  13480    F  S ITM= $O(^PXRMIN DX(63,"PI" ,DFN,ITM))  Q:$E(ITM) '="M"  I $ D(^PXRMIND X(63,"PI", DFN,ITM,CD T,IDX)) S  Y=ITM Q
  13481   "RTN","VPR DJ06",136, 0)
  13482    Q Y
  13483   "RTN","VPR DJ06",137, 0)
  13484    ;
  13485   "RTN","VPR DJ06",138, 0)
  13486   AP ; -- pa thology ID  = VPRSUB; VPRIDT
  13487   "RTN","VPR DJ06",139, 0)
  13488    N LAB,LR0 ,X,I,NODE
  13489   "RTN","VPR DJ06",140, 0)
  13490    N $ES,$ET ,ERRPAT,ER RMSG
  13491   "RTN","VPR DJ06",141, 0)
  13492    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  13493   "RTN","VPR DJ06",142, 0)
  13494    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he patholo gy domain"
  13495   "RTN","VPR DJ06",143, 0)
  13496    ;
  13497   "RTN","VPR DJ06",144, 0)
  13498    S LAB("lo calId")=ID ,LAB("orga nizerType" )="accessi on"
  13499   "RTN","VPR DJ06",145, 0)
  13500    S LAB("ui d")=$$SETU ID^VPRUTIL S("lab",DF N,ID)
  13501   "RTN","VPR DJ06",146, 0)
  13502    S LAB("ca tegoryCode ")="urn:va :lab-categ ory:"_VPRS UB
  13503   "RTN","VPR DJ06",147, 0)
  13504    S LAB("ca tegoryName ")=$S(VPRS UB="BB":"B lood Bank" ,VPRSUB="S P":"Surgic al Patholo gy",1:"Pat hology")
  13505   "RTN","VPR DJ06",148, 0)
  13506    S LAB("st atusCode") ="urn:va:l ab-status: completed" ,LAB("stat usName")=" completed"
  13507   "RTN","VPR DJ06",149, 0)
  13508    S CDT=999 9999-VPRID T,LAB("obs erved")=$$ DATE(CDT)
  13509   "RTN","VPR DJ06",150, 0)
  13510    S LR0=$G( ^LR(LRDFN, VPRSUB,VPR IDT,0))
  13511   "RTN","VPR DJ06",151, 0)
  13512    S LAB("re sulted")=$ $DATE($P(L R0,U,11)), LAB("group Name")=$P( LR0,U,6)
  13513   "RTN","VPR DJ06",152, 0)
  13514    S X="",I= 0 F  S I=$ O(^LR(LRDF N,VPRSUB,V PRIDT,.1,I )) Q:I<1   S X=X_$S($ L(X):", ", 1:"")_$P($ G(^(I,0)), U)
  13515   "RTN","VPR DJ06",153, 0)
  13516    S:$L(X) L AB("specim en")=X
  13517   "RTN","VPR DJ06",154, 0)
  13518    D FACILIT Y^VPRUTILS ($$FAC^VPR D,"LAB")
  13519   "RTN","VPR DJ06",155, 0)
  13520    S NODE=$S (VPRSUB="A U":$NA(^LR (LRDFN,101 )),1:$NA(^ LR(LRDFN,V PRSUB,VPRI DT,.05)))
  13521   "RTN","VPR DJ06",156, 0)
  13522    S I=0 F   S I=$O(@NO DE@(I)) Q: I<1  S X=+ $P($G(@NOD E@(I,0)),U ,2) I X D
  13523   "RTN","VPR DJ06",157, 0)
  13524    . N LT S  LT=$$GET1^ DIQ(8925,+ X_",",.01)  Q:$P(LT,"  ")="Adden dum"
  13525   "RTN","VPR DJ06",158, 0)
  13526    . S LAB(" results",I ,"uid")=LA B("uid")
  13527   "RTN","VPR DJ06",159, 0)
  13528    . S LAB(" results",I ,"resultUi d")=$$SETU ID^VPRUTIL S("documen t",DFN,X)
  13529   "RTN","VPR DJ06",160, 0)
  13530    . S LAB(" results",I ,"localTit le")=LT
  13531   "RTN","VPR DJ06",161, 0)
  13532    I '$O(LAB ("results" ,0)) D  ;n on-TIU rep orts
  13533   "RTN","VPR DJ06",162, 0)
  13534    . S LAB(" results",1 ,"uid")=LA B("uid")
  13535   "RTN","VPR DJ06",163, 0)
  13536    . S LAB(" results",1 ,"resultUi d")=$$SETU ID^VPRUTIL S("documen t",DFN,ID)
  13537   "RTN","VPR DJ06",164, 0)
  13538    . S LAB(" results",1 ,"localTit le")="LR " _$$NAME^VP RDLRA(VPRS UB)_" REPO RT"
  13539   "RTN","VPR DJ06",165, 0)
  13540    D ADD^VPR DJ("LAB"," lab")
  13541   "RTN","VPR DJ06",166, 0)
  13542    ;
  13543   "RTN","VPR DJ06",167, 0)
  13544   DATE(X) ;  -- strip o ff seconds , return J SON format
  13545   "RTN","VPR DJ06",168, 0)
  13546    N Y S Y=$ G(X)
  13547   "RTN","VPR DJ06",169, 0)
  13548    I $L($P(Y ,".",2))>4  S Y=$P(Y, ".")_"."_$ E($P(Y,"." ,2),1,4) ; strip seco nds
  13549   "RTN","VPR DJ06",170, 0)
  13550    S:Y Y=$$J SONDT^VPRU TILS(Y)
  13551   "RTN","VPR DJ06",171, 0)
  13552    Q Y
  13553   "RTN","VPR DJ07")
  13554   0^78^B2189 0653
  13555   "RTN","VPR DJ07",1,0)
  13556   VPRDJ07 ;S LC/MKB --  Radiology, Surgery ;6 /25/12  16 :11
  13557   "RTN","VPR DJ07",2,0)
  13558    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  13559   "RTN","VPR DJ07",3,0)
  13560    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  13561   "RTN","VPR DJ07",4,0)
  13562    ;
  13563   "RTN","VPR DJ07",5,0)
  13564    ; Externa l Referenc es           DBIA#
  13565   "RTN","VPR DJ07",6,0)
  13566    ; ------- ---------- --           -----
  13567   "RTN","VPR DJ07",7,0)
  13568    ; ^SC                             10040
  13569   "RTN","VPR DJ07",8,0)
  13570    ; ^VA(200                         10060
  13571   "RTN","VPR DJ07",9,0)
  13572    ; DIC                              2051
  13573   "RTN","VPR DJ07",10,0 )
  13574    ; DIQ                              2056
  13575   "RTN","VPR DJ07",11,0 )
  13576    ; RAO7PC1                    20 43,2265
  13577   "RTN","VPR DJ07",12,0 )
  13578    ; SROESTV                          3533
  13579   "RTN","VPR DJ07",13,0 )
  13580    ;
  13581   "RTN","VPR DJ07",14,0 )
  13582    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  13583   "RTN","VPR DJ07",15,0 )
  13584    ;
  13585   "RTN","VPR DJ07",16,0 )
  13586   RA1(ID) ;  -- radiolo gy exam ^T MP($J,"RAE 1",DFN,ID)
  13587   "RTN","VPR DJ07",17,0 )
  13588    N EXAM,X0 ,SET,PROC, DATE,LOC,X ,Y,IENS,ID 3,N
  13589   "RTN","VPR DJ07",18,0 )
  13590    N $ES,$ET ,ERRPAT,ER RMSG
  13591   "RTN","VPR DJ07",19,0 )
  13592    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  13593   "RTN","VPR DJ07",20,0 )
  13594    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he radiolo gy domain"
  13595   "RTN","VPR DJ07",21,0 )
  13596    ;
  13597   "RTN","VPR DJ07",22,0 )
  13598    S X0=$G(^ TMP($J,"RA E1",DFN,ID )),SET=$G( ^(ID,"CPRS ")),PROC=$ P(X0,U) Q: X0=""
  13599   "RTN","VPR DJ07",23,0 )
  13600    S EXAM("l ocalId")=I D,EXAM("ui d")=$$SETU ID^VPRUTIL S("image", DFN,ID)
  13601   "RTN","VPR DJ07",24,0 )
  13602    S EXAM("n ame")=PROC ,EXAM("cas e")=$P(X0, U,2),EXAM( "category" )="RA"
  13603   "RTN","VPR DJ07",25,0 )
  13604    S DATE=99 99999.9999 -+ID,EXAM( "dateTime" )=$$JSONDT ^VPRUTILS( DATE)
  13605   "RTN","VPR DJ07",26,0 )
  13606    I $P(X0,U ,5) D  ;re port exist s
  13607   "RTN","VPR DJ07",27,0 )
  13608    . N NM S  NM=$S(+SET =2:$P(SET, U,2),1:PRO C) ;2 = sh ared repor t
  13609   "RTN","VPR DJ07",28,0 )
  13610    . S EXAM( "results", 1,"uid")=$ $SETUID^VP RUTILS("do cument",DF N,ID)
  13611   "RTN","VPR DJ07",29,0 )
  13612    . S EXAM( "results", 1,"localTi tle")=NM
  13613   "RTN","VPR DJ07",30,0 )
  13614    . S EXAM( "verified" )=$S($E($P (X0,U,3))= "V":"true" ,1:"false" )
  13615   "RTN","VPR DJ07",31,0 )
  13616    S:$L($P(X 0,U,6)) EX AM("status Name")=$P( $P(X0,U,6) ,"~",2)
  13617   "RTN","VPR DJ07",32,0 )
  13618    S X=$P(X0 ,U,7),LOC= "" I $L(X)  D
  13619   "RTN","VPR DJ07",33,0 )
  13620    . S EXAM( "imageLoca tion")=X,E XAM("locat ionName")= X
  13621   "RTN","VPR DJ07",34,0 )
  13622    . S LOC=+ $O(^SC("B" ,X,0))
  13623   "RTN","VPR DJ07",35,0 )
  13624    . S EXAM( "locationU id")=$$SET UID^VPRUTI LS("locati on",,LOC)
  13625   "RTN","VPR DJ07",36,0 )
  13626    S X=$$FAC ^VPRD(LOC)  D FACILIT Y^VPRUTILS (X,"EXAM")
  13627   "RTN","VPR DJ07",37,0 )
  13628    I $L($P(X 0,U,8)) S  X=$P($P(X0 ,U,8),"~", 2),EXAM("i magingType Uid")=$$SE TVURN^VPRU TILS("imag ing-Type", X)
  13629   "RTN","VPR DJ07",38,0 )
  13630    S X=$P(X0 ,U,10) I X  D
  13631   "RTN","VPR DJ07",39,0 )
  13632    . N CPT S  CPT=$$CPT ^VPRDRA(X)
  13633   "RTN","VPR DJ07",40,0 )
  13634    . S (EXAM ("typeName "),EXAM("s ummary"))= $P(CPT,U,2 )
  13635   "RTN","VPR DJ07",41,0 )
  13636    . ;I $D(^ TMP($J,"RA E1",DFN,ID ,"CMOD"))  M EXAM("mo difier")=^ ("CMOD")
  13637   "RTN","VPR DJ07",42,0 )
  13638    I $P(X0,U ,11) D
  13639   "RTN","VPR DJ07",43,0 )
  13640    . S EXAM( "orderUid" )=$$SETUID ^VPRUTILS( "order",DF N,+$P(X0,U ,11))
  13641   "RTN","VPR DJ07",44,0 )
  13642    . S EXAM( "orderName ")=$S($L(S ET):$P(SET ,U,2),1:PR OC)
  13643   "RTN","VPR DJ07",45,0 )
  13644    S EXAM("h asImages") =$S($P(X0, U,12)="Y": "true",1:" false")
  13645   "RTN","VPR DJ07",46,0 )
  13646    I $P(X0,U ,4)="Y"!($ P(X0,U,9)= "Y") S EXA M("interpr etation")= "ABNORMAL"
  13647   "RTN","VPR DJ07",47,0 )
  13648    S IENS=$P (ID,"-",2) _","_+ID_" ,"_DFN_","
  13649   "RTN","VPR DJ07",48,0 )
  13650    S X=$$GET 1^DIQ(70.0 3,IENS,27, "I") I X D
  13651   "RTN","VPR DJ07",49,0 )
  13652    . S EXAM( "encounter Uid")=$$SE TUID^VPRUT ILS("visit ",DFN,+X)
  13653   "RTN","VPR DJ07",50,0 )
  13654    . S EXAM( "encounter Name")=$$N AME^VPRDJ0 4(+X)
  13655   "RTN","VPR DJ07",51,0 )
  13656    S ID3=DFN _U_$TR(ID, "-","^") D  EN3^RAO7P C1(ID3) D   ;get addi tional val ues
  13657   "RTN","VPR DJ07",52,0 )
  13658    . S X=+$G (^TMP($J," RAE2",DFN, +$P(ID3,U, 3),PROC,"P ")) Q:'X
  13659   "RTN","VPR DJ07",53,0 )
  13660    . S EXAM( "providers ",1,"provi derUid")=$ $SETUID^VP RUTILS("us er",,X)
  13661   "RTN","VPR DJ07",54,0 )
  13662    . S EXAM( "providers ",1,"provi derName")= $P($G(^VA( 200,X,0)), U),N=0
  13663   "RTN","VPR DJ07",55,0 )
  13664    . F  S N= $O(^TMP($J ,"RAE2",DF N,+$P(ID3, U,3),PROC, "D",N)) Q: N<1  S X=$ G(^(N)) D
  13665   "RTN","VPR DJ07",56,0 )
  13666    .. S EXAM ("diagnosi s",N,"code ")=X
  13667   "RTN","VPR DJ07",57,0 )
  13668    .. S:N=1  EXAM("diag nosis",N," primary")= "true"
  13669   "RTN","VPR DJ07",58,0 )
  13670    .. N EXP  S EXP=$$LE X(X) S:EXP  EXAM("dia gnosis",N, "lexicon") =X
  13671   "RTN","VPR DJ07",59,0 )
  13672    . K ^TMP( $J,"RAE2", DFN)
  13673   "RTN","VPR DJ07",60,0 )
  13674    S EXAM("k ind")="Ima ging"
  13675   "RTN","VPR DJ07",61,0 )
  13676    D ADD^VPR DJ("EXAM", "image")
  13677   "RTN","VPR DJ07",62,0 )
  13678    Q
  13679   "RTN","VPR DJ07",63,0 )
  13680    ;
  13681   "RTN","VPR DJ07",64,0 )
  13682   LEX(X) ; - - Return L exicon ptr  for a Dx  Code
  13683   "RTN","VPR DJ07",65,0 )
  13684    N X,Y,DIC ,LEX
  13685   "RTN","VPR DJ07",66,0 )
  13686    S DIC=78. 3,DIC(0)=" BFOXZ" D ^ DIC
  13687   "RTN","VPR DJ07",67,0 )
  13688    S LEX=$P( $G(Y(0)),U ,6)
  13689   "RTN","VPR DJ07",68,0 )
  13690    Q LEX
  13691   "RTN","VPR DJ07",69,0 )
  13692    ;
  13693   "RTN","VPR DJ07",70,0 )
  13694   SR1(ID) ;  -- surgery
  13695   "RTN","VPR DJ07",71,0 )
  13696    N SURG,VP RX,VPRY,X, Y,I
  13697   "RTN","VPR DJ07",72,0 )
  13698    D ONE^SRO ESTV("VPRY ",ID) S VP RX=$G(VPRY (ID)) Q:VP RX=""
  13699   "RTN","VPR DJ07",73,0 )
  13700    N $ES,$ET ,ERRPAT,ER RMSG
  13701   "RTN","VPR DJ07",74,0 )
  13702    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  13703   "RTN","VPR DJ07",75,0 )
  13704    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for t he surgery  domain"
  13705   "RTN","VPR DJ07",76,0 )
  13706    ;
  13707   "RTN","VPR DJ07",77,0 )
  13708    S SURG("l ocalId")=I D,SURG("ui d")=$$SETU ID^VPRUTIL S("surgery ",DFN,ID)
  13709   "RTN","VPR DJ07",78,0 )
  13710    S X=$P(VP RX,U,2),SU RG("status Name")="CO MPLETED"
  13711   "RTN","VPR DJ07",79,0 )
  13712    I X?1"* A borted * " .E S X=$E( X,13,999), SURG("stat usName")=" ABORTED"
  13713   "RTN","VPR DJ07",80,0 )
  13714    S (SURG(" typeName") ,SURG("sum mary"))=X
  13715   "RTN","VPR DJ07",81,0 )
  13716    S SURG("d ateTime")= $$JSONDT^V PRUTILS($P (VPRX,U,3) )
  13717   "RTN","VPR DJ07",82,0 )
  13718    S X=$P(VP RX,U,4) I  X D
  13719   "RTN","VPR DJ07",83,0 )
  13720    . S SURG( "providers ",1,"provi derUid")=$ $SETUID^VP RUTILS("us er",,+X)
  13721   "RTN","VPR DJ07",84,0 )
  13722    . S SURG( "providers ",1,"provi derName")= $P(X,";",2 )
  13723   "RTN","VPR DJ07",85,0 )
  13724    S X=$$GET 1^DIQ(130, ID_",",50, "I"),X=$$F AC^VPRD(X)
  13725   "RTN","VPR DJ07",86,0 )
  13726    D FACILIT Y^VPRUTILS (X,"SURG")
  13727   "RTN","VPR DJ07",87,0 )
  13728    S X=$$GET 1^DIQ(130, ID_",",.01 5,"I") I X  D
  13729   "RTN","VPR DJ07",88,0 )
  13730    . S SURG( "encounter Uid")=$$SE TUID^VPRUT ILS("visit ",DFN,+X)
  13731   "RTN","VPR DJ07",89,0 )
  13732    . S SURG( "encounter Name")=$$N AME^VPRDJ0 4(+X)
  13733   "RTN","VPR DJ07",90,0 )
  13734    S X=$$GET 1^DIQ(136, ID_",",.02 ,"I") I X  D
  13735   "RTN","VPR DJ07",91,0 )
  13736    . S X=$$C PT^VPRDSR( X)
  13737   "RTN","VPR DJ07",92,0 )
  13738    . S (SURG ("typeName "),SURG("s ummary"))= $P(X,U,2)
  13739   "RTN","VPR DJ07",93,0 )
  13740    . S SURG( "typeCode" )=$$SETNCS ^VPRUTILS( "cpt",+X)
  13741   "RTN","VPR DJ07",94,0 )
  13742    S I=0 F   S I=$O(VPR Y(ID,I)) Q :I<1  S X= $G(VPRY(ID ,I)) I X D
  13743   "RTN","VPR DJ07",95,0 )
  13744    . N LT S  LT=$P(X,U, 2) Q:$P(LT ," ")="Add endum"
  13745   "RTN","VPR DJ07",96,0 )
  13746    . S SURG( "results", I,"uid")=$ $SETUID^VP RUTILS("do cument",DF N,+X)
  13747   "RTN","VPR DJ07",97,0 )
  13748    . S SURG( "results", I,"localTi tle")=LT
  13749   "RTN","VPR DJ07",98,0 )
  13750    S SURG("k ind")="Sur gery",SURG ("category ")="SR"
  13751   "RTN","VPR DJ07",99,0 )
  13752    K ^TMP("T IULIST",$J )
  13753   "RTN","VPR DJ07",100, 0)
  13754    D ADD^VPR DJ("SURG", "surgery")
  13755   "RTN","VPR DJ07",101, 0)
  13756    Q
  13757   "RTN","VPR DJ08")
  13758   0^79^B6932 1777
  13759   "RTN","VPR DJ08",1,0)
  13760   VPRDJ08 ;S LC/MKB --  Documents  ;6/25/12   16:11
  13761   "RTN","VPR DJ08",2,0)
  13762    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  13763   "RTN","VPR DJ08",3,0)
  13764    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  13765   "RTN","VPR DJ08",4,0)
  13766    ;
  13767   "RTN","VPR DJ08",5,0)
  13768    ; Externa l Referenc es           DBIA#
  13769   "RTN","VPR DJ08",6,0)
  13770    ; ------- ---------- --           -----
  13771   "RTN","VPR DJ08",7,0)
  13772    ; ^SC                             10040
  13773   "RTN","VPR DJ08",8,0)
  13774    ; ^TIU(89 25.1               23 21,5677
  13775   "RTN","VPR DJ08",9,0)
  13776    ; ^TIU(89 26.1                     5678
  13777   "RTN","VPR DJ08",10,0 )
  13778    ; ^VA(200                         10060
  13779   "RTN","VPR DJ08",11,0 )
  13780    ; DIQ                              2056
  13781   "RTN","VPR DJ08",12,0 )
  13782    ; RAO7PC1                          2043
  13783   "RTN","VPR DJ08",13,0 )
  13784    ; TIUCNSL T                        5546
  13785   "RTN","VPR DJ08",14,0 )
  13786    ; TIUCP                            3568
  13787   "RTN","VPR DJ08",15,0 )
  13788    ; TIULQ                            2693
  13789   "RTN","VPR DJ08",16,0 )
  13790    ; TIULX                            3058
  13791   "RTN","VPR DJ08",17,0 )
  13792    ; TIUSROI                          5676
  13793   "RTN","VPR DJ08",18,0 )
  13794    ; TIUSRVL O                  28 34,2865
  13795   "RTN","VPR DJ08",19,0 )
  13796    ; XLFSTR                          10104
  13797   "RTN","VPR DJ08",20,0 )
  13798    ;
  13799   "RTN","VPR DJ08",21,0 )
  13800    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  13801   "RTN","VPR DJ08",22,0 )
  13802    ;
  13803   "RTN","VPR DJ08",23,0 )
  13804   TIU1(ID) ;  -- docume nt
  13805   "RTN","VPR DJ08",24,0 )
  13806    I ID[";"  D   Q
  13807   "RTN","VPR DJ08",25,0 )
  13808    . I ID D  EN1($$CP1^ VPRDJ08A(D FN,ID),"CP ") Q  ;CP
  13809   "RTN","VPR DJ08",26,0 )
  13810    . D EN1($ $LR1^VPRDJ 08A(DFN,ID ),"LR") Q        ;Lab
  13811   "RTN","VPR DJ08",27,0 )
  13812    I ID["-"  D  Q                                   ;Rad iology
  13813   "RTN","VPR DJ08",28,0 )
  13814    . S (BEG, END)=99999 99.9999-+I D D EN1^RA O7PC1(DFN, BEG,END,"9 9P")
  13815   "RTN","VPR DJ08",29,0 )
  13816    . Q:'$D(^ TMP($J,"RA E1",DFN,ID ))               ;del eted
  13817   "RTN","VPR DJ08",30,0 )
  13818    . D EN1($ $RA1^VPRDJ 08A(DFN,ID ),"RA") K  ^TMP($J,"R AE1")
  13819   "RTN","VPR DJ08",31,0 )
  13820    D EN1(ID, 38)
  13821   "RTN","VPR DJ08",32,0 )
  13822    Q
  13823   "RTN","VPR DJ08",33,0 )
  13824    ;
  13825   "RTN","VPR DJ08",34,0 )
  13826   EN1(VPRX,T IU) ; -- d ocument
  13827   "RTN","VPR DJ08",35,0 )
  13828    ;  Expect s DFN, VPR X=IEN^$$RE SOLVE^TIUS RVLO(IEN)  or equival ent
  13829   "RTN","VPR DJ08",36,0 )
  13830    ;           TIU = do cument cla ss#, or co de (CP, RA , LR) if n on-TIU
  13831   "RTN","VPR DJ08",37,0 )
  13832    N DOC,IEN ,X,VPRTIU, ES,I,TEXT, SUB,VPRY,E RR
  13833   "RTN","VPR DJ08",38,0 )
  13834    S IEN=$P( $G(VPRX),U ),TIU=$G(T IU) Q:IEN= ""  ;inval id ien
  13835   "RTN","VPR DJ08",39,0 )
  13836    ;
  13837   "RTN","VPR DJ08",40,0 )
  13838    I +VPRX=V PRX,TIU D   ;get TIU  data strin g, if need ed
  13839   "RTN","VPR DJ08",41,0 )
  13840    . N SHOWA DD,DA S SH OWADD=1,DA =+VPRX
  13841   "RTN","VPR DJ08",42,0 )
  13842    . S VPRX= DA_U_$$RES OLVE^TIUSR VLO(DA)
  13843   "RTN","VPR DJ08",43,0 )
  13844    Q:"UNKNOW N"[$P($G(V PRX),U,2)   ;null or  invalid
  13845   "RTN","VPR DJ08",44,0 )
  13846    N $ES,$ET ,ERRPAT,ER RMSG
  13847   "RTN","VPR DJ08",45,0 )
  13848    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  13849   "RTN","VPR DJ08",46,0 )
  13850    S ERRMSG= "A problem  occurred  converting  record "_ IEN_" for  the docume nt domain"
  13851   "RTN","VPR DJ08",47,0 )
  13852    S DOC("lo calId")=IE N,DOC("uid ")=$$SETUI D^VPRUTILS ("document ",DFN,IEN)
  13853   "RTN","VPR DJ08",48,0 )
  13854    S DOC("lo calTitle") =$P(VPRX,U ,2)
  13855   "RTN","VPR DJ08",49,0 )
  13856    S DOC("re ferenceDat eTime")=$$ JSONDT^VPR UTILS($P(V PRX,U,3))
  13857   "RTN","VPR DJ08",50,0 )
  13858    S X=$P(VP RX,U,6) D   ;S:$L(X)  DOC("locat ion")=X
  13859   "RTN","VPR DJ08",51,0 )
  13860    . N LOC,F AC S LOC=$ S($L(X):+$ O(^SC("B", X,0)),1:0)
  13861   "RTN","VPR DJ08",52,0 )
  13862    . S X=$$F AC^VPRD(LO C)
  13863   "RTN","VPR DJ08",53,0 )
  13864    . S DOC(" facilityCo de")=$P(X, U),DOC("fa cilityName ")=$P(X,U, 2)
  13865   "RTN","VPR DJ08",54,0 )
  13866    S X=$P(VP RX,U,7) I  $L(X) S DO C("status" )=$$UP^XLF STR(X)
  13867   "RTN","VPR DJ08",55,0 )
  13868    ;. N SUB  S SUB=$$FI ND1^DIC(89 30.6,,"QX" ,X)
  13869   "RTN","VPR DJ08",56,0 )
  13870    ;. S:SUB> 0 DOC("sta tusUid")=$ $SETUID^VP RUTILS("do c-status", ,SUB)
  13871   "RTN","VPR DJ08",57,0 )
  13872    S:$P(VPRX ,U,11) DOC ("images") =+$P(VPRX, U,11)
  13873   "RTN","VPR DJ08",58,0 )
  13874    S:$L($P(V PRX,U,12))  DOC("subj ect")=$P(V PRX,U,12)
  13875   "RTN","VPR DJ08",59,0 )
  13876    I $P(VPRX ,U,14)>5 S  DOC("pare ntUid")=$$ SETUID^VPR UTILS("doc ument",DFN ,$P(VPRX,U ,14)) ;ID  notes
  13877   "RTN","VPR DJ08",60,0 )
  13878   B ; other  TIU data
  13879   "RTN","VPR DJ08",61,0 )
  13880    D:TIU EXT RACT^TIULQ (IEN,"VPRT IU",,,,1,, 1) ;".01:. 04;1501:15 08")
  13881   "RTN","VPR DJ08",62,0 )
  13882    S X=$G(VP RTIU(IEN,. 01,"I")) S :X DOC("do cumentDefU id")=$$SET UID^VPRUTI LS("doc-de f",,X)
  13883   "RTN","VPR DJ08",63,0 )
  13884    S X=$G(VP RTIU(IEN,1 201,"I"))  S:X DOC("e ntered")=$ $JSONDT^VP RUTILS(X)
  13885   "RTN","VPR DJ08",64,0 )
  13886    S X=$G(VP RTIU(IEN,. 09,"E")) S :$L(X) DOC ("urgency" )=X
  13887   "RTN","VPR DJ08",65,0 )
  13888    S X=TIU I  TIU S X=+ $G(VPRTIU( IEN,.01,"I ")),X=$$CA TG^VPRDTIU (X) ;2U ty pe code
  13889   "RTN","VPR DJ08",66,0 )
  13890    S DOC("do cumentType Code")=X,D OC("docume ntTypeName ")=$$TYPE( X)
  13891   "RTN","VPR DJ08",67,0 )
  13892    S DOC("do cumentClas s")=$S(X=" LR":"LR LA BORATORY R EPORTS",X= "SR":"SURG ICAL REPOR TS",X="CP" :"CLINICAL  PROCEDURE S",X="RA": "RADIOLOGY  REPORTS", X="DS":"DI SCHARGE SU MMARY",1:" PROGRESS N OTES")
  13893   "RTN","VPR DJ08",68,0 )
  13894    S X=$S(TI U:$G(VPRTI U(IEN,.03, "I")),1:$P (VPRX,U,8) ) ;visit#
  13895   "RTN","VPR DJ08",69,0 )
  13896    S:X DOC(" encounterU id")=$$SET UID^VPRUTI LS("visit" ,DFN,X),DO C("encount erName")=$ $NAME^VPRD J04(X)
  13897   "RTN","VPR DJ08",70,0 )
  13898   C ; text b locks, sig natures
  13899   "RTN","VPR DJ08",71,0 )
  13900    N VPRT,VP RA,VPRADD
  13901   "RTN","VPR DJ08",72,0 )
  13902    S DOC("te xt",1,"dat eTime")=DO C("referen ceDateTime ")
  13903   "RTN","VPR DJ08",73,0 )
  13904    S DOC("te xt",1,"sta tus")=$G(D OC("status "))
  13905   "RTN","VPR DJ08",74,0 )
  13906    S DOC("te xt",1,"uid ")=DOC("ui d")
  13907   "RTN","VPR DJ08",75,0 )
  13908    S VPRT=1, X=$P(VPRX, U,5),I=0
  13909   "RTN","VPR DJ08",76,0 )
  13910    I X D USE R(.I,+X,$P (X,";",3), "AU")    ; author
  13911   "RTN","VPR DJ08",77,0 )
  13912    M ES=VPRT IU(IEN) S  X=$P(VPRX, "//",2) ;n on-TIU, pu t into ES  for use:
  13913   "RTN","VPR DJ08",78,0 )
  13914    I $L(X) S  ES(1502," I")=+X,ES( 1502,"E")= $P(X,";",2 ),ES(1501, "I")=$P(X, ";",3)
  13915   "RTN","VPR DJ08",79,0 )
  13916    I $G(ES(1 501,"I"))  D USER(.I, ES(1502,"I "),ES(1502 ,"E"),"S", ES(1501,"I "),$G(ES(1 503,"E")), $G(ES(1504 ,"E")))
  13917   "RTN","VPR DJ08",80,0 )
  13918    I $G(ES(1 507,"I"))  D USER(.I, ES(1508,"I "),ES(1508 ,"E"),"C", ES(1507,"I "),$G(ES(1 509,"E")), $G(ES(1510 ,"E")))
  13919   "RTN","VPR DJ08",81,0 )
  13920    I $G(ES(1 204,"I"))  D USER(.I, ES(1204,"I "),ES(1204 ,"E"),"ES" )    ;expe cted signe r
  13921   "RTN","VPR DJ08",82,0 )
  13922    I $G(ES(1 208,"I"))  D USER(.I, ES(1208,"I "),ES(1208 ,"E"),"EC" )    ;expe cted cosig ner
  13923   "RTN","VPR DJ08",83,0 )
  13924    I $G(ES(1 302,"I"))  D USER(.I, ES(1302,"I "),ES(1302 ,"E"),"E")      ;ente red
  13925   "RTN","VPR DJ08",84,0 )
  13926    I $G(ES(1 209,"I"))  D USER(.I, ES(1209,"I "),ES(1209 ,"E"),"ATT ")   ;atte nding
  13927   "RTN","VPR DJ08",85,0 )
  13928    I $G(VPRT EXT) D
  13929   "RTN","VPR DJ08",86,0 )
  13930    . S X=$S( TIU:$NA(VP RTIU(IEN," TEXT")),1: $NA(^TMP(" VPRTEXT",$ J,IEN)))
  13931   "RTN","VPR DJ08",87,0 )
  13932    . K ^TMP( $J,"VPR TI U TEXT")
  13933   "RTN","VPR DJ08",88,0 )
  13934    . D SETTE XT^VPRUTIL S(X,$NA(^T MP($J,"VPR  TIU TEXT" )))
  13935   "RTN","VPR DJ08",89,0 )
  13936    . M DOC(" text",1,"c ontent","\ ")=^TMP($J ,"VPR TIU  TEXT")
  13937   "RTN","VPR DJ08",90,0 )
  13938   D ; addend a
  13939   "RTN","VPR DJ08",91,0 )
  13940    S VPRA=0  F  S VPRA= $O(VPRTIU( IEN,"ZADD" ,VPRA)) Q: VPRA<1  D
  13941   "RTN","VPR DJ08",92,0 )
  13942    . S VPRT= VPRT+1,I=0  K VPRADD  M VPRADD=V PRTIU(IEN, "ZADD",VPR A)
  13943   "RTN","VPR DJ08",93,0 )
  13944    . S DOC(" text",VPRT ,"status") =$G(VPRADD (.05,"E"))
  13945   "RTN","VPR DJ08",94,0 )
  13946    . S DOC(" text",VPRT ,"uid")=$$ SETUID^VPR UTILS("doc ument",DFN ,VPRA)
  13947   "RTN","VPR DJ08",95,0 )
  13948    . S DOC(" text",VPRT ,"dateTime ")=$$JSOND T^VPRUTILS ($G(VPRADD (1301,"I") ))
  13949   "RTN","VPR DJ08",96,0 )
  13950    . I $G(VP RADD(1302, "I")) D US ER(.I,VPRA DD(1302,"I "),VPRADD( 1302,"E"), "E")
  13951   "RTN","VPR DJ08",97,0 )
  13952    . I $G(VP RADD(1202, "I")) D US ER(.I,VPRA DD(1202,"I "),VPRADD( 1202,"E"), "AU")
  13953   "RTN","VPR DJ08",98,0 )
  13954    . I $G(VP RADD(1501, "I")) D US ER(.I,VPRA DD(1502,"I "),VPRADD( 1502,"E"), "S",VPRADD (1501,"I") )
  13955   "RTN","VPR DJ08",99,0 )
  13956    . I $G(VP RADD(1507, "I")) D US ER(.I,VPRA DD(1508,"I "),VPRADD( 1508,"E"), "C",VPRADD (1507,"I") )
  13957   "RTN","VPR DJ08",100, 0)
  13958    . I $G(VP RADD(1204, "I")) D US ER(.I,VPRA DD(1204,"I "),VPRADD( 1204,"E"), "ES")
  13959   "RTN","VPR DJ08",101, 0)
  13960    . I $G(VP RADD(1208, "I")) D US ER(.I,VPRA DD(1208,"I "),VPRADD( 1208,"E"), "EC")
  13961   "RTN","VPR DJ08",102, 0)
  13962    . I $G(VP RADD(1209, "I")) D US ER(.I,VPRA DD(1209,"I "),VPRADD( 1209,"E"), "ATT")
  13963   "RTN","VPR DJ08",103, 0)
  13964    . Q:'$G(V PRTEXT)  K  ^TMP($J," VPR TIU TE XT")
  13965   "RTN","VPR DJ08",104, 0)
  13966    . S X=$NA (VPRTIU(IE N,"ZADD",V PRA,"TEXT" ))
  13967   "RTN","VPR DJ08",105, 0)
  13968    . D SETTE XT^VPRUTIL S(X,$NA(^T MP($J,"VPR  TIU TEXT" )))
  13969   "RTN","VPR DJ08",106, 0)
  13970    . M DOC(" text",VPRT ,"content" ,"\")=^TMP ($J,"VPR T IU TEXT")
  13971   "RTN","VPR DJ08",107, 0)
  13972   ENQ ; end
  13973   "RTN","VPR DJ08",108, 0)
  13974    K ^TMP($J ,"VPR TIU  TEXT")
  13975   "RTN","VPR DJ08",109, 0)
  13976    D ADD^VPR DJ("DOC"," document")
  13977   "RTN","VPR DJ08",110, 0)
  13978    Q
  13979   "RTN","VPR DJ08",111, 0)
  13980    ;
  13981   "RTN","VPR DJ08",112, 0)
  13982   USER(N,IEN ,NAME,ROLE ,DATE,SBN, SBT) ; --  set author , signer(s )
  13983   "RTN","VPR DJ08",113, 0)
  13984    Q:'$G(IEN )  S N=+$G (N)+1
  13985   "RTN","VPR DJ08",114, 0)
  13986    S DOC("te xt",VPRT," clinicians ",N,"uid") =$$SETUID^ VPRUTILS(" user",,IEN )
  13987   "RTN","VPR DJ08",115, 0)
  13988    S DOC("te xt",VPRT," clinicians ",N,"name" )=$S($L($G (NAME)):NA ME,1:$P($G (^VA(200,I EN,0)),U))
  13989   "RTN","VPR DJ08",116, 0)
  13990    S DOC("te xt",VPRT," clinicians ",N,"role" )=$G(ROLE)
  13991   "RTN","VPR DJ08",117, 0)
  13992    Q:'$G(DAT E)  ;not c o/signed
  13993   "RTN","VPR DJ08",118, 0)
  13994    S DOC("te xt",VPRT," clinicians ",N,"signe dDateTime" )=$$JSONDT ^VPRUTILS( DATE)
  13995   "RTN","VPR DJ08",119, 0)
  13996    I '$D(SBN ) S SBN=NA ME
  13997   "RTN","VPR DJ08",120, 0)
  13998    S DOC("te xt",VPRT," clinicians ",N,"signa ture")=SBN _$S($L($G( SBT)):" "_ SBT,1:"")
  13999   "RTN","VPR DJ08",121, 0)
  14000    ;$$SIG^VP RDTIU(IEN)
  14001   "RTN","VPR DJ08",122, 0)
  14002    Q
  14003   "RTN","VPR DJ08",123, 0)
  14004    ;
  14005   "RTN","VPR DJ08",124, 0)
  14006   NATL ; --  national t itle [not  used -- in  docDef no w]
  14007   "RTN","VPR DJ08",125, 0)
  14008    S X=$S(TI U:$$GET1^D IQ(8925,IE N_",",".01 :1501","I" ),1:$P(VPR X,U,10))
  14009   "RTN","VPR DJ08",126, 0)
  14010    I X D  ;N ational Ti tle + attr ibutes
  14011   "RTN","VPR DJ08",127, 0)
  14012    . N IENS, TIU,Y,FNUM
  14013   "RTN","VPR DJ08",128, 0)
  14014    . S IENS= X_"," D GE TS^DIQ(892 6.1,IENS," *","IE","T IU")
  14015   "RTN","VPR DJ08",129, 0)
  14016    . S DOC(" nationalTi tle","vuid ")="urn:va :vuid:"_$G (TIU(8926. 1,IENS,99. 99,"E"))
  14017   "RTN","VPR DJ08",130, 0)
  14018    . S DOC(" nationalTi tle","name ")=$G(TIU( 8926.1,IEN S,.01,"E") )
  14019   "RTN","VPR DJ08",131, 0)
  14020    . F I=".0 4^Subject^ 2",".05^Ro le^3",".06 ^Setting^4 ",".07^Ser vice^5",". 08^Type^6"  D
  14021   "RTN","VPR DJ08",132, 0)
  14022    .. S Y=+$ G(TIU(8926 .1,IENS,+I ,"I")) Q:Y '>0
  14023   "RTN","VPR DJ08",133, 0)
  14024    .. S FNUM ="8926."_+ $P(I,U,3)
  14025   "RTN","VPR DJ08",134, 0)
  14026    .. S DOC( "nationalT itle"_$P(I ,U,2),"vui d")="urn:v a:vuid:"_$ $VUID^VPRD (Y,FNUM)
  14027   "RTN","VPR DJ08",135, 0)
  14028    .. S DOC( "nationalT itle"_$P(I ,U,2),"nam e")=$G(TIU (8926.1,IE NS,+I,"E") )
  14029   "RTN","VPR DJ08",136, 0)
  14030    Q
  14031   "RTN","VPR DJ08",137, 0)
  14032    ;
  14033   "RTN","VPR DJ08",138, 0)
  14034    ; ------- ----- Get/ apply sear ch criteri a -------- ----
  14035   "RTN","VPR DJ08",139, 0)
  14036    ;                [fr om DOCUMEN T^VPRDJ0]
  14037   "RTN","VPR DJ08",140, 0)
  14038    ;
  14039   "RTN","VPR DJ08",141, 0)
  14040   SETUP ; --  convert F ILTER("att ribute") =  value to  TIU criter ia
  14041   "RTN","VPR DJ08",142, 0)
  14042    ; Expects : FILTER(" category")  = code (s ee $$CATG)
  14043   "RTN","VPR DJ08",143, 0)
  14044    ;           FILTER(" status")    = 'signed ','unsigne d','all'
  14045   "RTN","VPR DJ08",144, 0)
  14046    ; Returns : CLASS,[S UBCLASS,ST ATUS]
  14047   "RTN","VPR DJ08",145, 0)
  14048    ;
  14049   "RTN","VPR DJ08",146, 0)
  14050    N TYPE,ST S,CP
  14051   "RTN","VPR DJ08",147, 0)
  14052    S TYPE=$$ UP^XLFSTR( $G(FILTER( "category" )))
  14053   "RTN","VPR DJ08",148, 0)
  14054    S CLASS=0 ,(SUBCLASS ,STATUS)=" "
  14055   "RTN","VPR DJ08",149, 0)
  14056    ;
  14057   "RTN","VPR DJ08",150, 0)
  14058    ; status  [default=' signed']
  14059   "RTN","VPR DJ08",151, 0)
  14060    S STS=$$L OW^XLFSTR( $G(FILTER( "status")) )
  14061   "RTN","VPR DJ08",152, 0)
  14062    S STATUS= $S(STS?1"u nsig".E:2, STS="all": "5^2",1:5)      ;TIUS RVLO statu ses
  14063   "RTN","VPR DJ08",153, 0)
  14064    ;
  14065   "RTN","VPR DJ08",154, 0)
  14066    ; all doc uments
  14067   "RTN","VPR DJ08",155, 0)
  14068    S:TYPE=""  TYPE="ALL "
  14069   "RTN","VPR DJ08",156, 0)
  14070    I TYPE="A LL" S CLAS S="3^244^" _+$$CLASS^ TIUSROI("S URGICAL RE PORTS")_"^ CP^LR^RA"  Q
  14071   "RTN","VPR DJ08",157, 0)
  14072    ;
  14073   "RTN","VPR DJ08",158, 0)
  14074    I TYPE="P N"   S CLA SS=3 Q                               ;Progr ess Notes
  14075   "RTN","VPR DJ08",159, 0)
  14076    I TYPE="C R"   S CLA SS=3,SUBCL ASS=$$CLAS S^TIUCNSLT  Q  ;Consu lts
  14077   "RTN","VPR DJ08",160, 0)
  14078    I TYPE="C WAD" S CLA SS=3,SUBCL ASS="25^27 ^30^31" Q      ;CWAD
  14079   "RTN","VPR DJ08",161, 0)
  14080    I TYPE="C "    S CLA SS=3,SUBCL ASS=30 Q                  ;Crisi s Note
  14081   "RTN","VPR DJ08",162, 0)
  14082    I TYPE="W "    S CLA SS=3,SUBCL ASS=31 Q                  ;Clini cal Warnin g
  14083   "RTN","VPR DJ08",163, 0)
  14084    I TYPE="A "    S CLA SS=3,SUBCL ASS=25 Q                  ;Aller gy Note
  14085   "RTN","VPR DJ08",164, 0)
  14086    I TYPE="D "    S CLA SS=3,SUBCL ASS=27 Q                  ;Advan ce Directi ve
  14087   "RTN","VPR DJ08",165, 0)
  14088    ;
  14089   "RTN","VPR DJ08",166, 0)
  14090    I TYPE="D S"   S CLA SS=244 Q                             ;Disch arge Summa ry
  14091   "RTN","VPR DJ08",167, 0)
  14092    ;
  14093   "RTN","VPR DJ08",168, 0)
  14094    I TYPE="S R"   S CLA SS=$$CLASS ^TIUSROI(" SURGICAL R EPORTS") Q
  14095   "RTN","VPR DJ08",169, 0)
  14096    I TYPE="C P" D  Q                                         ;Clin  Procedures
  14097   "RTN","VPR DJ08",170, 0)
  14098    . I STATU S'=2 S CLA SS="CP"                              ; if u nsigned,
  14099   "RTN","VPR DJ08",171, 0)
  14100    . E  D CP CLASS^TIUC P(.CP) S C LASS=CP                   ; use  TIU class#
  14101   "RTN","VPR DJ08",172, 0)
  14102    ;
  14103   "RTN","VPR DJ08",173, 0)
  14104    I TYPE="L R"   S CLA SS=$S(STAT US=2:$$LR, 1:"LR") Q      ;Lab/P athology
  14105   "RTN","VPR DJ08",174, 0)
  14106    ;
  14107   "RTN","VPR DJ08",175, 0)
  14108    I TYPE="R A"   S CLA SS="RA" Q                            ;Radio logy
  14109   "RTN","VPR DJ08",176, 0)
  14110    ;
  14111   "RTN","VPR DJ08",177, 0)
  14112    Q
  14113   "RTN","VPR DJ08",178, 0)
  14114    ;
  14115   "RTN","VPR DJ08",179, 0)
  14116   LR() ; --  Return ien  of Lab cl ass
  14117   "RTN","VPR DJ08",180, 0)
  14118    N Y S Y=+ $O(^TIU(89 25.1,"B"," LR LABORAT ORY REPORT S",0))
  14119   "RTN","VPR DJ08",181, 0)
  14120    I Y>0,$S( $P($G(^TIU (8925.1,Y, 0)),U,4)=" CL":0,$P($ G(^(0)),U, 4)="DC":0, 1:1) S Y=0
  14121   "RTN","VPR DJ08",182, 0)
  14122    Q Y
  14123   "RTN","VPR DJ08",183, 0)
  14124    ;
  14125   "RTN","VPR DJ08",184, 0)
  14126   MATCH(DOC, STS) ; --  Return 1 o r 0, if do cument DA  matches se arch crite ria
  14127   "RTN","VPR DJ08",185, 0)
  14128    N Y,DA,LO CAL,NATL,X 0,OK S Y=0
  14129   "RTN","VPR DJ08",186, 0)
  14130    S DA=+$G( DOC) G:DA< 1 MQ
  14131   "RTN","VPR DJ08",187, 0)
  14132    ; include  addenda i f pulling  only unsig ned items
  14133   "RTN","VPR DJ08",188, 0)
  14134    I $P(DOC, U,2)?1"Add endum ".E, STATUS'=2  G MQ
  14135   "RTN","VPR DJ08",189, 0)
  14136    ; TIU uns igned list  can inclu de complet ed parent  notes
  14137   "RTN","VPR DJ08",190, 0)
  14138    I $G(STS) =2,$P(DOC, U,7)'="uns igned" G M Q
  14139   "RTN","VPR DJ08",191, 0)
  14140    S LOCAL=$ $GET1^DIQ( 8925,DA_", ",.01,"I")  ;local Ti tle 8925.1  ien
  14141   "RTN","VPR DJ08",192, 0)
  14142    I $L(SUBC LASS) D  G :'OK MQ
  14143   "RTN","VPR DJ08",193, 0)
  14144    . N I,X S  OK=0
  14145   "RTN","VPR DJ08",194, 0)
  14146    . F I=1:1 :$L(SUBCLA SS,"^") S  X=$P(SUBCL ASS,U,I) I  $$ISA^TIU LX(LOCAL,X ) S OK=1 Q
  14147   "RTN","VPR DJ08",195, 0)
  14148    S Y=1
  14149   "RTN","VPR DJ08",196, 0)
  14150   MQ Q Y
  14151   "RTN","VPR DJ08",197, 0)
  14152    ;
  14153   "RTN","VPR DJ08",198, 0)
  14154   TYPE(X) ;  -- Return  name of ca tegory typ e X
  14155   "RTN","VPR DJ08",199, 0)
  14156    S X=$G(X)
  14157   "RTN","VPR DJ08",200, 0)
  14158    I X="PN"  Q "Progres s Note"
  14159   "RTN","VPR DJ08",201, 0)
  14160    I X="DS"  Q "Dischar ge Summary "
  14161   "RTN","VPR DJ08",202, 0)
  14162    I X="CP"  Q "Clinica l Procedur e"
  14163   "RTN","VPR DJ08",203, 0)
  14164    I X="SR"  Q "Surgery  Report"
  14165   "RTN","VPR DJ08",204, 0)
  14166    I X="LR"  Q "Laborat ory Report "
  14167   "RTN","VPR DJ08",205, 0)
  14168    I X="RA"  Q "Radiolo gy Report"
  14169   "RTN","VPR DJ08",206, 0)
  14170    I X="CR"  Q "Consult  Report"
  14171   "RTN","VPR DJ08",207, 0)
  14172    I X="C"   Q "Crisis  Note"
  14173   "RTN","VPR DJ08",208, 0)
  14174    I X="W"   Q "Clinica l Warning"
  14175   "RTN","VPR DJ08",209, 0)
  14176    I X="A"   Q "Allergy /Adverse R eaction"
  14177   "RTN","VPR DJ08",210, 0)
  14178    I X="D"   Q "Advance  Directive "
  14179   "RTN","VPR DJ08",211, 0)
  14180    Q ""
  14181   "RTN","VPR DJ08A")
  14182   0^82^B4451 7876
  14183   "RTN","VPR DJ08A",1,0 )
  14184   VPRDJ08A ; SLC/MKB --  Documents  cont ;6/2 5/12  16:1 1
  14185   "RTN","VPR DJ08A",2,0 )
  14186    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  14187   "RTN","VPR DJ08A",3,0 )
  14188    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  14189   "RTN","VPR DJ08A",4,0 )
  14190    ;
  14191   "RTN","VPR DJ08A",5,0 )
  14192    ; Externa l Referenc es           DBIA#
  14193   "RTN","VPR DJ08A",6,0 )
  14194    ; ------- ---------- --           -----
  14195   "RTN","VPR DJ08A",7,0 )
  14196    ; ^DPT                            10035
  14197   "RTN","VPR DJ08A",8,0 )
  14198    ; ^LR                               525
  14199   "RTN","VPR DJ08A",9,0 )
  14200    ; ^RADPT                           2480
  14201   "RTN","VPR DJ08A",10, 0)
  14202    ; ^RARPT                           5605
  14203   "RTN","VPR DJ08A",11, 0)
  14204    ; ^SC                             10040
  14205   "RTN","VPR DJ08A",12, 0)
  14206    ; ^TMP("M DHSP" [MDP S1]           4230
  14207   "RTN","VPR DJ08A",13, 0)
  14208    ; ^VA(200                         10060
  14209   "RTN","VPR DJ08A",14, 0)
  14210    ; %DT                             10003
  14211   "RTN","VPR DJ08A",15, 0)
  14212    ; DIQ                              2056
  14213   "RTN","VPR DJ08A",16, 0)
  14214    ; GMRCGUI B                        2980
  14215   "RTN","VPR DJ08A",17, 0)
  14216    ; LR7OR1, ^TMP("LRRR "             2503
  14217   "RTN","VPR DJ08A",18, 0)
  14218    ; MCARUTL 3                        3280
  14219   "RTN","VPR DJ08A",19, 0)
  14220    ; PXAPI                            1894
  14221   "RTN","VPR DJ08A",20, 0)
  14222    ; RAO7PC1                    20 43,2265
  14223   "RTN","VPR DJ08A",21, 0)
  14224    ; RAO7PC3                          2877
  14225   "RTN","VPR DJ08A",22, 0)
  14226    ;
  14227   "RTN","VPR DJ08A",23, 0)
  14228    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  14229   "RTN","VPR DJ08A",24, 0)
  14230    ;
  14231   "RTN","VPR DJ08A",25, 0)
  14232    ; ------- ---------- ---------- ---------- ---------- ---------- ---------
  14233   "RTN","VPR DJ08A",26, 0)
  14234    ; documen tClass = C LINICAL PR OCEDURES
  14235   "RTN","VPR DJ08A",27, 0)
  14236    ; nationa lTitle = 4 696566^PRO CEDURE REP ORT
  14237   "RTN","VPR DJ08A",28, 0)
  14238    ;       S ervice = 4 696471^PRO CEDURE
  14239   "RTN","VPR DJ08A",29, 0)
  14240    ;           Type = 4 696123^REP ORT
  14241   "RTN","VPR DJ08A",30, 0)
  14242    ;
  14243   "RTN","VPR DJ08A",31, 0)
  14244   CP(DFN,BEG ,END,MAX)  ; -- Medic ine report s
  14245   "RTN","VPR DJ08A",32, 0)
  14246    N VPRN,VP RX,RTN,TIU N,CONS,VPR D,I,DA,X,Y ,%DT,DATE, GBL
  14247   "RTN","VPR DJ08A",33, 0)
  14248    S DFN=+$G (DFN) Q:$G (DFN)<1
  14249   "RTN","VPR DJ08A",34, 0)
  14250    D MDPS1^V PRDJ03(DFN ,BEG,END,M AX)              ;get s ^TMP("MD HSP",$J)
  14251   "RTN","VPR DJ08A",35, 0)
  14252    S VPRN=0  F  S VPRN= $O(^TMP("M DHSP",$J,V PRN)) Q:VP RN<1  S VP RX=$G(^(VP RN)) D
  14253   "RTN","VPR DJ08A",36, 0)
  14254    . N $ES,$ ET,ERRPAT, ERRMSG
  14255   "RTN","VPR DJ08A",37, 0)
  14256    . S $ET=" D ERRHDLR^ VPRDERRH", ERRPAT=DFN
  14257   "RTN","VPR DJ08A",38, 0)
  14258    . S ERRMS G="A probl em occurre d converti ng a medic ine report ."
  14259   "RTN","VPR DJ08A",39, 0)
  14260    . S RTN=$ P(VPRX,U,3 ,4)  Q:RTN ="PRPRO^MD PS4"  ;ski p non-CP i tems
  14261   "RTN","VPR DJ08A",40, 0)
  14262    . S TIUN= +$P(VPRX,U ,14)
  14263   "RTN","VPR DJ08A",41, 0)
  14264    . I TIUN  D EN1^VPRD J08(TIUN,3 8)               ;38= TIU Clinic al Documen t
  14265   "RTN","VPR DJ08A",42, 0)
  14266    . S CONS= +$P(VPRX,U ,13) D:CON S DOCLIST^ GMRCGUIB(. VPRD,CONS)
  14267   "RTN","VPR DJ08A",43, 0)
  14268    . K DA S  I=0 F  S I =$O(VPRD(5 0,I)) Q:I< 1  D
  14269   "RTN","VPR DJ08A",44, 0)
  14270    .. S DA=+ VPRD(50,I)  Q:DA=TIUN
  14271   "RTN","VPR DJ08A",45, 0)
  14272    .. D EN1^ VPRDJ08(DA ,38)
  14273   "RTN","VPR DJ08A",46, 0)
  14274    . Q:TIUN! $G(DA)                                 ;don e [got TIU  note(s)]
  14275   "RTN","VPR DJ08A",47, 0)
  14276    . Q:RTN=" PR702^MDPS 1"                          ;CP,  but no TI U note yet
  14277   "RTN","VPR DJ08A",48, 0)
  14278    . Q:RTN=" PRPRO^MDPS 4"                          ;non -CP proced ure
  14279   "RTN","VPR DJ08A",49, 0)
  14280    . ; find  ID for pre -TIU repor t
  14281   "RTN","VPR DJ08A",50, 0)
  14282    . S X=$P( VPRX,U,6), %DT="TXS"  D ^%DT Q:Y '>0  S DAT E=Y
  14283   "RTN","VPR DJ08A",51, 0)
  14284    . S GBL=+ $P(VPRX,U, 2)_";"_$$R OOT^VPRDMC (DFN,$P(VP RX,U,11),D ATE)
  14285   "RTN","VPR DJ08A",52, 0)
  14286    . I GBL S  X=$$CP1(D FN,GBL) D  EN1^VPRDJ0 8(X,"CP")
  14287   "RTN","VPR DJ08A",53, 0)
  14288    K ^TMP("M DHSP",$J), ^TMP("VPRT EXT",$J)
  14289   "RTN","VPR DJ08A",54, 0)
  14290    Q
  14291   "RTN","VPR DJ08A",55, 0)
  14292    ;
  14293   "RTN","VPR DJ08A",56, 0)
  14294   CP1(DFN,ID ) ; -- ret urn report  data as T IU string  [$$RESOLVE ]
  14295   "RTN","VPR DJ08A",57, 0)
  14296    S DFN=+$G (DFN),ID=$ G(ID) I DF N<1!'$L(ID ) Q ""
  14297   "RTN","VPR DJ08A",58, 0)
  14298    N Y,VPRY, VPRFN,X,NA ME,DATE,ST S,USER,SIG N,TEXT
  14299   "RTN","VPR DJ08A",59, 0)
  14300    S VPRFN=+ $P(ID,"(", 2)
  14301   "RTN","VPR DJ08A",60, 0)
  14302    D MEDLKUP ^MCARUTL3( .VPRY,VPRF N,+ID)
  14303   "RTN","VPR DJ08A",61, 0)
  14304    I VPRY<1  Q ""  ;err or in CP
  14305   "RTN","VPR DJ08A",62, 0)
  14306    S NAME=$P (VPRY,U,9) ,DATE=$P(V PRY,U,6)
  14307   "RTN","VPR DJ08A",63, 0)
  14308    S X=$$GET 1^DIQ(VPRF N,+ID_",", 1506)
  14309   "RTN","VPR DJ08A",64, 0)
  14310    S STS=$S( $L(X):X,1: "COMPLETED ")
  14311   "RTN","VPR DJ08A",65, 0)
  14312    S X=+$$GE T1^DIQ(VPR FN,+ID_"," ,701,"I"), (USER,SIGN )=""
  14313   "RTN","VPR DJ08A",66, 0)
  14314    S:X USER= X_";;"_$P( $G(^VA(200 ,X,0)),U)
  14315   "RTN","VPR DJ08A",67, 0)
  14316    S X=+$$GE T1^DIQ(VPR FN,+ID_"," ,1503,"I")
  14317   "RTN","VPR DJ08A",68, 0)
  14318    S:X SIGN= "//"_X_";" _$P($G(^VA (200,X,0)) ,U)_";"_$$ GET1^DIQ(V PRFN,+ID_" ,",1505,"I ")
  14319   "RTN","VPR DJ08A",69, 0)
  14320    ; VST=$$G ET1^DIQ(VP RFN,+ID_", ",900,"I")
  14321   "RTN","VPR DJ08A",70, 0)
  14322    S Y=ID_U_ NAME_U_DAT E_U_U_USER _U_U_STS_" ^^^2461^"_ SIGN
  14323   "RTN","VPR DJ08A",71, 0)
  14324    S:$G(VPRT EXT) TEXT= $$TEXT^VPR DMC(DFN,ID ,NAME) ;^T MP("VPRTEX T",$J,ID)
  14325   "RTN","VPR DJ08A",72, 0)
  14326    Q Y
  14327   "RTN","VPR DJ08A",73, 0)
  14328    ;
  14329   "RTN","VPR DJ08A",74, 0)
  14330    ; ------- ---------- ---------- ---------- ---------- ---------- ---------
  14331   "RTN","VPR DJ08A",75, 0)
  14332    ; documen tClass = L R LABORATO RY REPORTS
  14333   "RTN","VPR DJ08A",76, 0)
  14334    ; nationa lTitle = 4 697105^LAB ORATORY NO TE
  14335   "RTN","VPR DJ08A",77, 0)
  14336    ;       S ubject = 4 697104^LAB ORATORY
  14337   "RTN","VPR DJ08A",78, 0)
  14338    ;           Type = 4 696120^NOT E
  14339   "RTN","VPR DJ08A",79, 0)
  14340    ;
  14341   "RTN","VPR DJ08A",80, 0)
  14342   LR(DFN,BEG ,END,MAX)  ; -- Lab r eports
  14343   "RTN","VPR DJ08A",81, 0)
  14344    N VPRSUB, VPRIDT,VPR ITM,VPRTIU ,VPRXID,LR DFN,IVDT,V PRN,DA
  14345   "RTN","VPR DJ08A",82, 0)
  14346    S DFN=+$G (DFN) Q:$G (DFN)<1
  14347   "RTN","VPR DJ08A",83, 0)
  14348    S BEG=$G( BEG,141010 1),END=$G( END,414101 5),MAX=$G( MAX,9999)
  14349   "RTN","VPR DJ08A",84, 0)
  14350    S LRDFN=+ $G(^DPT(DF N,"LR")),I VDT=999999 9-+$G(^LR( LRDFN,"AU" )) ;LR7OB6 3D error
  14351   "RTN","VPR DJ08A",85, 0)
  14352    K ^TMP("L RRR",$J,DF N) D RR^LR 7OR1(DFN,, BEG,END,"M IAP",,,MAX )
  14353   "RTN","VPR DJ08A",86, 0)
  14354    S VPRSUB= "" F  S VP RSUB=$O(^T MP("LRRR", $J,DFN,VPR SUB)) Q:VP RSUB=""  D
  14355   "RTN","VPR DJ08A",87, 0)
  14356    . S VPRID T=0 F  S V PRIDT=$O(^ TMP("LRRR" ,$J,DFN,VP RSUB,VPRID T)) Q:VPRI DT<1  I $O (^(VPRIDT, 0)) D
  14357   "RTN","VPR DJ08A",88, 0)
  14358    .. S VPRT IU=$S(VPRS UB="AU":$N A(^LR(LRDF N,101)),1: $NA(^LR(LR DFN,VPRSUB ,VPRIDT,.0 5)))
  14359   "RTN","VPR DJ08A",89, 0)
  14360    .. K VPRI TM S VPRXI D=VPRSUB_" ;"_VPRIDT
  14361   "RTN","VPR DJ08A",90, 0)
  14362    .. I '$O( @VPRTIU@(0 )) S VPRX= $$LR1(DFN, VPRXID) D  EN1^VPRDJ0 8(VPRX,"LR ") Q
  14363   "RTN","VPR DJ08A",91, 0)
  14364    .. S VPRN =0 F  S VP RN=$O(@VPR TIU@(VPRN) ) Q:VPRN<1   D  ;38=T IU Clin Do c
  14365   "RTN","VPR DJ08A",92, 0)
  14366    ... S DA= +$P($G(@VP RTIU@(VPRN ,0)),U,2)
  14367   "RTN","VPR DJ08A",93, 0)
  14368    ... D:DA  EN1^VPRDJ0 8(DA,38)
  14369   "RTN","VPR DJ08A",94, 0)
  14370    K ^TMP("L RRR",$J,DF N),^TMP("V PRTEXT",$J )
  14371   "RTN","VPR DJ08A",95, 0)
  14372    Q
  14373   "RTN","VPR DJ08A",96, 0)
  14374    ;
  14375   "RTN","VPR DJ08A",97, 0)
  14376   LR1(DFN,ID ) ; -- ret urn report  data as T IU string  [$$RESOLVE ]
  14377   "RTN","VPR DJ08A",98, 0)
  14378    N $ES,$ET ,ERRPAT,ER RMSG
  14379   "RTN","VPR DJ08A",99, 0)
  14380    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  14381   "RTN","VPR DJ08A",100 ,0)
  14382    S ERRMSG= "A problem  occurred  converting  lab repor t "_ID
  14383   "RTN","VPR DJ08A",101 ,0)
  14384    S DFN=+$G (DFN),ID=$ G(ID) I DF N<1!'$L(ID ) Q ""
  14385   "RTN","VPR DJ08A",102 ,0)
  14386    N Y,SUB,I DT,LRDFN,L R,NAME,LOC ,USER,VST, SIGN,TEXT
  14387   "RTN","VPR DJ08A",103 ,0)
  14388    K ^TMP("V PRTEXT",$J ,ID)
  14389   "RTN","VPR DJ08A",104 ,0)
  14390    S SUB=$P( ID,";"),ID T=+$P(ID," ;",2),LRDF N=$G(^DPT( DFN,"LR"))
  14391   "RTN","VPR DJ08A",105 ,0)
  14392    S LR=$S(S UB="AU":$G (^LR(LRDFN ,"AU")),1: $G(^LR(LRD FN,SUB,IDT ,0)))
  14393   "RTN","VPR DJ08A",106 ,0)
  14394    S NAME="L R "_$$NAME ^VPRDLRA(S UB)_" REPO RT"
  14395   "RTN","VPR DJ08A",107 ,0)
  14396    S LOC=$P( LR,U,$S(SU B="AU":5,1 :8)) D  ;l ook-up vis it
  14397   "RTN","VPR DJ08A",108 ,0)
  14398    . N CDT,S C S CDT=99 99999-IDT, SC="",X=0
  14399   "RTN","VPR DJ08A",109 ,0)
  14400    . S:$L(LO C) SC=+$O( ^SC("B",LO C,0))
  14401   "RTN","VPR DJ08A",110 ,0)
  14402    . I CDT,L OC S X=$$G ETENC^PXAP I(DFN,CDT, SC)
  14403   "RTN","VPR DJ08A",111 ,0)
  14404    . S:X VST =+X
  14405   "RTN","VPR DJ08A",112 ,0)
  14406    S X=+$P(L R,U,$S(SUB ="AU":10,S UB="MI":4, 1:2)) ;pat hologist[a uthor]
  14407   "RTN","VPR DJ08A",113 ,0)
  14408    S USER=$S (X:X_";;"_ $P($G(^VA( 200,X,0)), U),1:""),S IGN=""
  14409   "RTN","VPR DJ08A",114 ,0)
  14410    S X=$S(SU B="AU":$P( LR,U,15,16 ),SUB="MI" :$P(LR,U,3 ,4),1:$P(L R,U,11)_U_ $P(LR,U,13 )) ;releas ed
  14411   "RTN","VPR DJ08A",115 ,0)
  14412    S:X SIGN= "//"_+$P(X ,U,2)_";"_ $P($G(^VA( 200,+$P(X, U,2),0)),U )_";"_+X
  14413   "RTN","VPR DJ08A",116 ,0)
  14414    S Y=ID_U_ NAME_U_(99 99999-IDT) _U_U_USER_ U_LOC_"^CO MPLETED^"_ $G(VST)_"^ ^2753^"_SI GN
  14415   "RTN","VPR DJ08A",117 ,0)
  14416    S:$G(VPRT EXT) TEXT= $$TEXT^VPR DLRA(DFN,S UB,IDT) ;^ TMP("VPRTE XT",$J,ID)
  14417   "RTN","VPR DJ08A",118 ,0)
  14418    Q Y
  14419   "RTN","VPR DJ08A",119 ,0)
  14420    ;
  14421   "RTN","VPR DJ08A",120 ,0)
  14422    ; ------- ---------- ---------- ---------- ---------- ---------- ---------
  14423   "RTN","VPR DJ08A",121 ,0)
  14424    ; nationa lTitle = 4 695068^RAD IOLOGY REP ORT
  14425   "RTN","VPR DJ08A",122 ,0)
  14426    ;       S ubject = 4 693357^RAD IOLOGY
  14427   "RTN","VPR DJ08A",123 ,0)
  14428    ;           Type = 4 696123^REP ORT
  14429   "RTN","VPR DJ08A",124 ,0)
  14430    ;
  14431   "RTN","VPR DJ08A",125 ,0)
  14432   RA(DFN,BEG ,END,MAX)  ; -- Radio logy repor ts
  14433   "RTN","VPR DJ08A",126 ,0)
  14434    N VPRXID, STS,PSET
  14435   "RTN","VPR DJ08A",127 ,0)
  14436    S DFN=+$G (DFN) Q:DF N<1
  14437   "RTN","VPR DJ08A",128 ,0)
  14438    S BEG=$G( BEG,141010 1),END=$G( END,414101 5),MAX=$G( MAX,9999)_ "P"
  14439   "RTN","VPR DJ08A",129 ,0)
  14440    K ^TMP($J ,"RAE1") D  EN1^RAO7P C1(DFN,BEG ,END,MAX)
  14441   "RTN","VPR DJ08A",130 ,0)
  14442    S VPRXID= "" F  S VP RXID=$O(^T MP($J,"RAE 1",DFN,VPR XID)) Q:VP RXID=""  D
  14443   "RTN","VPR DJ08A",131 ,0)
  14444    . S STS=$ P($G(^TMP( $J,"RAE1", DFN,VPRXID )),U,3),PS ET=$G(^(VP RXID,"CPRS "))
  14445   "RTN","VPR DJ08A",132 ,0)
  14446    . Q:STS=" No Report" !(STS="Del eted")  ;! (STS["Draf t")
  14447   "RTN","VPR DJ08A",133 ,0)
  14448    . I +PSET =2,$G(PSET (+VPRXID,$ P(PSET,U,2 ))) Q  ;al ready have  report
  14449   "RTN","VPR DJ08A",134 ,0)
  14450    . S VPRX= $$RA1(DFN, VPRXID) D  EN1^VPRDJ0 8(VPRX,"RA ")
  14451   "RTN","VPR DJ08A",135 ,0)
  14452    . I +PSET =2 S PSET( +VPRXID,$P (PSET,U,2) )=$P(VPRXI D,"-",2) ; parent
  14453   "RTN","VPR DJ08A",136 ,0)
  14454    K ^TMP($J ,"RAE1"),^ TMP("VPRTE XT",$J)
  14455   "RTN","VPR DJ08A",137 ,0)
  14456    Q
  14457   "RTN","VPR DJ08A",138 ,0)
  14458    ;
  14459   "RTN","VPR DJ08A",139 ,0)
  14460   RA1(DFN,ID ) ; -- ret urn report  data as T IU string  [$$RESOLVE ]
  14461   "RTN","VPR DJ08A",140 ,0)
  14462    N $ES,$ET ,ERRPAT,ER RMSG
  14463   "RTN","VPR DJ08A",141 ,0)
  14464    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  14465   "RTN","VPR DJ08A",142 ,0)
  14466    S ERRMSG= "A problem  occurred  converting  radiology  report "_ ID
  14467   "RTN","VPR DJ08A",143 ,0)
  14468    S DFN=+$G (DFN),ID=$ G(ID) I DF N<1!'$L(ID ) Q ""
  14469   "RTN","VPR DJ08A",144 ,0)
  14470    N EXAM,CA SE,PROC,RA E3,RAE1,TE XT,I,X,Y,D ATE,LOC,ST S,IENS,VST ,USER,SIGN
  14471   "RTN","VPR DJ08A",145 ,0)
  14472    K RPT,^TM P("VPRTEXT ",$J,ID)
  14473   "RTN","VPR DJ08A",146 ,0)
  14474    S EXAM=DF N_U_$TR(ID ,"-","^")  D
  14475   "RTN","VPR DJ08A",147 ,0)
  14476    . N DFN D  EN3^RAO7P C3(EXAM) ; report
  14477   "RTN","VPR DJ08A",148 ,0)
  14478    . D EN3^R AO7PC1(EXA M)       ; add'l valu es
  14479   "RTN","VPR DJ08A",149 ,0)
  14480    S CASE=$O (^TMP($J," RAE3",DFN, 0)),PROC=$ O(^(CASE," ")),RAE3=$ G(^(PROC))
  14481   "RTN","VPR DJ08A",150 ,0)
  14482    S RAE1=$G (^TMP($J," RAE1",DFN, ID))
  14483   "RTN","VPR DJ08A",151 ,0)
  14484    I $G(VPRT EXT) D
  14485   "RTN","VPR DJ08A",152 ,0)
  14486    . S TEXT= $NA(^TMP(" VPRTEXT",$ J,ID))
  14487   "RTN","VPR DJ08A",153 ,0)
  14488    . S I=0 F   S I=$O(^ TMP($J,"RA E3",DFN,CA SE,PROC,I) ) Q:I<1  S  X=^(I),@T EXT@(I)=X
  14489   "RTN","VPR DJ08A",154 ,0)
  14490    S DATE=99 99999.9999 -(+ID),LOC =$P(RAE1,U ,7),STS=$P (RAE3,U)
  14491   "RTN","VPR DJ08A",155 ,0)
  14492    S IENS=$P (ID,"-",2) _","_+ID_" ,"_DFN_","
  14493   "RTN","VPR DJ08A",156 ,0)
  14494    S VST=$$G ET1^DIQ(70 .03,IENS,2 7,"I")
  14495   "RTN","VPR DJ08A",157 ,0)
  14496    S X=+$G(^ TMP($J,"RA E2",DFN,CA SE,PROC,"P ")),(USER, SIGN)=""
  14497   "RTN","VPR DJ08A",158 ,0)
  14498    S:X USER= X_";;"_$P( $G(^VA(200 ,X,0)),U)
  14499   "RTN","VPR DJ08A",159 ,0)
  14500    S X=$G(^T MP($J,"RAE 2",DFN,CAS E,PROC,"V" ))
  14501   "RTN","VPR DJ08A",160 ,0)
  14502    S:X SIGN= "//"_+X_"; "_$P($G(^V A(200,+X,0 )),U)_";"_ $$GET1^DIQ (74,+$P(RA E1,U,5)_", ",7,"I")
  14503   "RTN","VPR DJ08A",161 ,0)
  14504    I $D(^TMP ($J,"RAE3" ,DFN,"PRIN T_SET")) S  PROC=$G(^ ("ORD")) ; use parent , if print set
  14505   "RTN","VPR DJ08A",162 ,0)
  14506    S Y=ID_U_ PROC_U_DAT E_U_U_USER _U_LOC_U_S TS_U_VST_" ^^1901^"_S IGN
  14507   "RTN","VPR DJ08A",163 ,0)
  14508    K ^TMP($J ,"RAE3",DF N),^TMP($J ,"RAE2",DF N)
  14509   "RTN","VPR DJ08A",164 ,0)
  14510    Q Y
  14511   "RTN","VPR DJ09")
  14512   0^80^B3917 4048
  14513   "RTN","VPR DJ09",1,0)
  14514   VPRDJ09 ;S LC/MKB --  PCE ;8/2/1 1  15:29
  14515   "RTN","VPR DJ09",2,0)
  14516    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  14517   "RTN","VPR DJ09",3,0)
  14518    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  14519   "RTN","VPR DJ09",4,0)
  14520    ;
  14521   "RTN","VPR DJ09",5,0)
  14522    ; Externa l Referenc es           DBIA#
  14523   "RTN","VPR DJ09",6,0)
  14524    ; ------- ---------- --           -----
  14525   "RTN","VPR DJ09",7,0)
  14526    ; ^AUPNVS IT                       2028
  14527   "RTN","VPR DJ09",8,0)
  14528    ; ^PXRMIN DX                       4290
  14529   "RTN","VPR DJ09",9,0)
  14530    ; ^SC                             10040
  14531   "RTN","VPR DJ09",10,0 )
  14532    ; ^VA(200                         10060
  14533   "RTN","VPR DJ09",11,0 )
  14534    ; DIC                              2051
  14535   "RTN","VPR DJ09",12,0 )
  14536    ; DILFD                            2055
  14537   "RTN","VPR DJ09",13,0 )
  14538    ; DIQ                              2056
  14539   "RTN","VPR DJ09",14,0 )
  14540    ; PXAPI,^ TMP("PXKEN C"            1894
  14541   "RTN","VPR DJ09",15,0 )
  14542    ; VALM1                           10116
  14543   "RTN","VPR DJ09",16,0 )
  14544    ; XUAF4                            2171
  14545   "RTN","VPR DJ09",17,0 )
  14546    ;
  14547   "RTN","VPR DJ09",18,0 )
  14548    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  14549   "RTN","VPR DJ09",19,0 )
  14550    ;
  14551   "RTN","VPR DJ09",20,0 )
  14552   PX(FNUM) ;  -- PCE it em(s)
  14553   "RTN","VPR DJ09",21,0 )
  14554    I $G(VPRI D) D PXA(V PRID) Q
  14555   "RTN","VPR DJ09",22,0 )
  14556    N VPRIDT, ID D SORT  ;sort ^PXR MINDX into  ^TMP("VPR PX",$J,IDT )
  14557   "RTN","VPR DJ09",23,0 )
  14558    S VPRIDT= 0 F  S VPR IDT=$O(^TM P("VPRPX", $J,VPRIDT) ) Q:VPRIDT <1  D  Q:V PRI'<VPRMA X
  14559   "RTN","VPR DJ09",24,0 )
  14560    . S ID=0  F  S ID=$O (^TMP("VPR PX",$J,VPR IDT,ID)) Q :ID<1  D P X1 Q:VPRI' <VPRMAX
  14561   "RTN","VPR DJ09",25,0 )
  14562    K ^TMP("V PRPX",$J)
  14563   "RTN","VPR DJ09",26,0 )
  14564    Q
  14565   "RTN","VPR DJ09",27,0 )
  14566    ;
  14567   "RTN","VPR DJ09",28,0 )
  14568   PXA(ID) ;  -- find ID  in ^PXRMI NDX(FNUM),  fall thru  to PX1 if  successfu l
  14569   "RTN","VPR DJ09",29,0 )
  14570    N N,ROOT, IDX,P,ITEM ,DATE,VPRI DT
  14571   "RTN","VPR DJ09",30,0 )
  14572    S N=+$P(F NUM,".",2)  K ^TMP("V PRPX",$J)
  14573   "RTN","VPR DJ09",31,0 )
  14574    I N=7!(N= 18) S ROOT ="^PXRMIND X("_FNUM_" ,""PPI""," _+$G(DFN)
  14575   "RTN","VPR DJ09",32,0 )
  14576    E  S ROOT ="^PXRMIND X("_FNUM_" ,""PI"","_ +$G(DFN)
  14577   "RTN","VPR DJ09",33,0 )
  14578    S IDX=ROO T_")" F  S  IDX=$Q(@I DX) Q:$P(I DX,",",1,3 )'=ROOT  D
  14579   "RTN","VPR DJ09",34,0 )
  14580    . S P=$L( IDX,",") Q :ID'=+$P(I DX,",",P)   ;last sub script
  14581   "RTN","VPR DJ09",35,0 )
  14582    . S DATE= +$P(IDX,", ",P-1),ITE M=+$P(IDX, ",",P-2)
  14583   "RTN","VPR DJ09",36,0 )
  14584    . S VPRID T=9999999- DATE,^TMP( "VPRPX",$J ,VPRIDT,ID )=ITEM_U_D ATE
  14585   "RTN","VPR DJ09",37,0 )
  14586    Q:'$D(^TM P("VPRPX", $J))  ;not  found
  14587   "RTN","VPR DJ09",38,0 )
  14588   PX1 ; -- P CE ^TMP("V PRPX",$J,V PRIDT,ID)= ITM^DATE f or FNUM
  14589   "RTN","VPR DJ09",39,0 )
  14590    N N,COLL, TAG,VPRF,F LD,TMP,VIS IT,X0,X12, FAC,LOC,X, Y,PCE
  14591   "RTN","VPR DJ09",40,0 )
  14592    N $ES,$ET ,ERRPAT,ER RMSG
  14593   "RTN","VPR DJ09",41,0 )
  14594    S $ET="D  ERRHDLR^VP RDERRH",ER RPAT=DFN
  14595   "RTN","VPR DJ09",42,0 )
  14596    S N=+$P(F NUM,".",2) ,TAG=$S(N= 7:"VPOV",N =11:"VIMM" ,N=12:"VSK IN",N=13:" VXAM",N=16 :"VPEDU",N =18:"VCPT" ,1:"VHF")
  14597   "RTN","VPR DJ09",43,0 )
  14598    S ERRMSG= "A problem  occurred  converting  record "_ ID_" for " _TAG
  14599   "RTN","VPR DJ09",44,0 )
  14600    D @(TAG_" ^PXPXRM(ID ,.VPRF)")
  14601   "RTN","VPR DJ09",45,0 )
  14602    ;
  14603   "RTN","VPR DJ09",46,0 )
  14604    S PCE("lo calId")=ID ,TMP=$G(^T MP("VPRPX" ,$J,VPRIDT ,ID))
  14605   "RTN","VPR DJ09",47,0 )
  14606    S COLL=$S (N=7:"pov" ,N=11:"imm unization" ,N=12:"ski n",N=13:"e xam",N=16: "education ",N=18:"cp t",1:"fact or")
  14607   "RTN","VPR DJ09",48,0 )
  14608    S PCE("ui d")=$$SETU ID^VPRUTIL S(COLL,DFN ,ID)
  14609   "RTN","VPR DJ09",49,0 )
  14610    ; TAG=$S( N=23:"reco rded",N=11 :"administ eredDateTi me",1:"dat eTimeEnter ed")
  14611   "RTN","VPR DJ09",50,0 )
  14612    S TAG=$S( N=11:"admi nisteredDa teTime",1: "entered")
  14613   "RTN","VPR DJ09",51,0 )
  14614    S PCE(TAG )=$$JSONDT ^VPRUTILS( $P(TMP,U,2 ))
  14615   "RTN","VPR DJ09",52,0 )
  14616    S PCE("na me")=$$EXT ERNAL^DILF D(FNUM,.01 ,,+TMP)
  14617   "RTN","VPR DJ09",53,0 )
  14618    S VISIT=+ $G(VPRF("V ISIT")),PC E("encount erUid")=$$ SETUID^VPR UTILS("vis it",DFN,VI SIT)
  14619   "RTN","VPR DJ09",54,0 )
  14620    S PCE("en counterNam e")=$$NAME ^VPRDJ04(V ISIT)
  14621   "RTN","VPR DJ09",55,0 )
  14622    S X0=$G(^ AUPNVSIT(+ VISIT,0)), FAC=+$P(X0 ,U,6),LOC= +$P(X0,U,2 2)
  14623   "RTN","VPR DJ09",56,0 )
  14624    S:FAC X=$ $STA^XUAF4 (FAC)_U_$P ($$NS^XUAF 4(FAC),U)
  14625   "RTN","VPR DJ09",57,0 )
  14626    S:'FAC X= $$FAC^VPRD (LOC)
  14627   "RTN","VPR DJ09",58,0 )
  14628    D FACILIT Y^VPRUTILS (X,"PCE")
  14629   "RTN","VPR DJ09",59,0 )
  14630    S:LOC PCE ("location Uid")=$$SE TUID^VPRUT ILS("locat ion",,LOC) ,PCE("loca tionName") =$P($G(^SC (LOC,0)),U )
  14631   "RTN","VPR DJ09",60,0 )
  14632    S X=$G(VP RF("COMMEN TS")) S:$L (X) PCE("c omment")=X
  14633   "RTN","VPR DJ09",61,0 )
  14634   POV I FNUM =9000010.0 7 D  G PXQ
  14635   "RTN","VPR DJ09",62,0 )
  14636    . S X=$G( VPRF("PRIM ARY/SECOND ARY")),PCE ("type")=$ S($L(X):X, 1:"U")
  14637   "RTN","VPR DJ09",63,0 )
  14638    . S X=PCE ("name"),P CE("icdCod e")=$$SETN CS^VPRUTIL S("icd",X)
  14639   "RTN","VPR DJ09",64,0 )
  14640    . S X=$G( VPRF("PROV IDER NARRA TIVE")),PC E("name")= $$EXTERNAL ^DILFD(900 0010.07,.0 4,,X)
  14641   "RTN","VPR DJ09",65,0 )
  14642   CPT I FNUM =9000010.1 8 D  G PXQ
  14643   "RTN","VPR DJ09",66,0 )
  14644    . S X=$G( VPRF("PRIN CIPAL PROC EDURE")),P CE("type") =$S($L(X): X,1:"U")
  14645   "RTN","VPR DJ09",67,0 )
  14646    . S X=PCE ("name"),P CE("cptCod e")=$$SETN CS^VPRUTIL S("cpt",X)
  14647   "RTN","VPR DJ09",68,0 )
  14648    . S X=$G( VPRF("PROV IDER NARRA TIVE")),PC E("name")= $$EXTERNAL ^DILFD(900 0010.18,.0 4,,X)
  14649   "RTN","VPR DJ09",69,0 )
  14650    . S PCE(" quantity") =VPRF("QUA NTITY")
  14651   "RTN","VPR DJ09",70,0 )
  14652    S X=$G(VP RF("VALUE" )),FLD=$S( FNUM=90000 10.16:.06, 1:.04)
  14653   "RTN","VPR DJ09",71,0 )
  14654    S Y=$$EXT ERNAL^DILF D(FNUM,FLD ,,X)
  14655   "RTN","VPR DJ09",72,0 )
  14656   IM I FNUM= 9000010.11  D  G PXQ  ;immunizat ion
  14657   "RTN","VPR DJ09",73,0 )
  14658    . S:$L(Y)  PCE("seri esName")=Y ,PCE("seri esCode")=$ $SETUID^VP RUTILS("se ries",DFN, Y)
  14659   "RTN","VPR DJ09",74,0 )
  14660    . S X=$G( VPRF("REAC TION")) I  $L(X) D
  14661   "RTN","VPR DJ09",75,0 )
  14662    .. S PCE( "reactionN ame")=$$EX TERNAL^DIL FD(9000010 .11,.06,,X )
  14663   "RTN","VPR DJ09",76,0 )
  14664    .. S PCE( "reactionC ode")=$$SE TUID^VPRUT ILS("react ion",DFN,X )
  14665   "RTN","VPR DJ09",77,0 )
  14666    . S PCE(" contraindi cated")=$S (+$G(VPRF( "CONTRAIND ICATED")): "true",1:" false")
  14667   "RTN","VPR DJ09",78,0 )
  14668    . I '$D(^ TMP("PXKEN C",$J,VISI T)) D ENCE VENT^PXAPI (VISIT,1)
  14669   "RTN","VPR DJ09",79,0 )
  14670    . S X12=$ G(^TMP("PX KENC",$J,V ISIT,"IMM" ,ID,12))
  14671   "RTN","VPR DJ09",80,0 )
  14672    . S X=$P( X12,U,4) S :'X X=$P(X 12,U,2)
  14673   "RTN","VPR DJ09",81,0 )
  14674    . I 'X S  I=0 F  S I =$O(^TMP(" PXKENC",$J ,VISIT,"PR V",I)) Q:I <1  I $P($ G(^(I,0)), U,4)="P" S  X=+^(0) Q
  14675   "RTN","VPR DJ09",82,0 )
  14676    . S:X PCE ("performe rUid")=$$S ETUID^VPRU TILS("user ",,+X),PCE ("performe rName")=$P ($G(^VA(20 0,X,0)),U)
  14677   "RTN","VPR DJ09",83,0 )
  14678    . ; CPT m apping
  14679   "RTN","VPR DJ09",84,0 )
  14680    . S X=+$$ FIND1^DIC( 811.1,,"QX ",+TMP_";A UTTIMM("," B") I X>0  D
  14681   "RTN","VPR DJ09",85,0 )
  14682    .. S Y=$$ GET1^DIQ(8 11.1,X_"," ,.02,"I")  Q:Y<1
  14683   "RTN","VPR DJ09",86,0 )
  14684    .. N CPT  S CPT=$G(@ (U_$P(Y,"; ",2)_+Y_", 0)"))
  14685   "RTN","VPR DJ09",87,0 )
  14686    .. S PCE( "cptCode") =$$SETNCS^ VPRUTILS(" cpt",+CPT)
  14687   "RTN","VPR DJ09",88,0 )
  14688    .. S (PCE ("summary" ),PCE("cpt Name"))=$P (CPT,U,2)
  14689   "RTN","VPR DJ09",89,0 )
  14690   HF I FNUM= 9000010.23  D  G PXQ  ;health fa ctor
  14691   "RTN","VPR DJ09",90,0 )
  14692    . S:$L(X)  PCE("seve rityUid")= $$SETVURN^ VPRUTILS(" factor-sev erity",X), PCE("sever ityName")= $$LOWER^VA LM1(Y)
  14693   "RTN","VPR DJ09",91,0 )
  14694    . S X=$$G ET1^DIQ(99 99999.64,+ TMP_",",.0 3,"I") I X  D
  14695   "RTN","VPR DJ09",92,0 )
  14696    .. S PCE( "categoryU id")=$$SET VURN^VPRUT ILS("facto r-category ",X)
  14697   "RTN","VPR DJ09",93,0 )
  14698    .. S PCE( "categoryN ame")=$$EX TERNAL^DIL FD(9999999 .64,.03,"" ,X)
  14699   "RTN","VPR DJ09",94,0 )
  14700    . S X=$$G ET1^DIQ(99 99999.64,+ TMP_",",.0 8)
  14701   "RTN","VPR DJ09",95,0 )
  14702    . I $E(X) ="Y" S PCE ("display" )="true"
  14703   "RTN","VPR DJ09",96,0 )
  14704    . S PCE(" kind")="He alth Facto r",PCE("su mmary")=PC E("name")
  14705   "RTN","VPR DJ09",97,0 )
  14706   SK I FNUM= 9000010.12  D  ;skin  test [fall  thru to s et result]
  14707   "RTN","VPR DJ09",98,0 )
  14708    . S X=$G( VPRF("READ ING")) S:$ L(X) PCE(" reading")= X
  14709   "RTN","VPR DJ09",99,0 )
  14710    . S X=$G( VPRF("DATE  READ")) S :X PCE("da teRead")=$ $JSONDT^VP RUTILS(X)
  14711   "RTN","VPR DJ09",100, 0)
  14712    S:$L(Y) P CE("result ")=Y
  14713   "RTN","VPR DJ09",101, 0)
  14714   PXQ ;finis h
  14715   "RTN","VPR DJ09",102, 0)
  14716    D ADD^VPR DJ("PCE",C OLL)
  14717   "RTN","VPR DJ09",103, 0)
  14718    Q
  14719   "RTN","VPR DJ09",104, 0)
  14720    ;
  14721   "RTN","VPR DJ09",105, 0)
  14722   SORT ; --  build ^TMP ("VPRPX",$ J,9999999- DATE,DA)=I TEM^DATE i n range
  14723   "RTN","VPR DJ09",106, 0)
  14724    N TYPE,IT EM,DATE,DA ,IDT K ^TM P("VPRPX", $J)
  14725   "RTN","VPR DJ09",107, 0)
  14726    I FNUM=90 00010.07!( FNUM=90000 10.18) G P PI
  14727   "RTN","VPR DJ09",108, 0)
  14728   PI ; from  ^PXRMINDX( FNUM,"PI", DFN,ITEM,D ATE,DA)
  14729   "RTN","VPR DJ09",109, 0)
  14730    S ITEM=0  F  S ITEM= $O(^PXRMIN DX(FNUM,"P I",+$G(DFN ),ITEM)) Q :ITEM<1  D
  14731   "RTN","VPR DJ09",110, 0)
  14732    . S DATE= 0 F  S DAT E=$O(^PXRM INDX(FNUM, "PI",+$G(D FN),ITEM,D ATE)) Q:DA TE<1  D
  14733   "RTN","VPR DJ09",111, 0)
  14734    .. Q:DATE <VPRSTART   Q:DATE>VP RSTOP  S I DT=9999999 -DATE
  14735   "RTN","VPR DJ09",112, 0)
  14736    .. S DA=0  F  S DA=$ O(^PXRMIND X(FNUM,"PI ",+$G(DFN) ,ITEM,DATE ,DA)) Q:DA <1  S ^TMP ("VPRPX",$ J,IDT,DA)= ITEM_U_DAT E
  14737   "RTN","VPR DJ09",113, 0)
  14738    Q
  14739   "RTN","VPR DJ09",114, 0)
  14740   PPI ; from  ^PXRMINDX (FNUM,"PPI ",DFN,TYPE ,ITEM,DATE ,DA)
  14741   "RTN","VPR DJ09",115, 0)
  14742    S TYPE=""  F  S TYPE =$O(^PXRMI NDX(FNUM," PPI",+$G(D FN),TYPE))  Q:TYPE=""   D
  14743   "RTN","VPR DJ09",116, 0)
  14744    . S ITEM= 0 F  S ITE M=$O(^PXRM INDX(FNUM, "PPI",+$G( DFN),TYPE, ITEM)) Q:I TEM<1  D
  14745   "RTN","VPR DJ09",117, 0)
  14746    .. S DATE =0 F  S DA TE=$O(^PXR MINDX(FNUM ,"PPI",+$G (DFN),TYPE ,ITEM,DATE )) Q:DATE< 1  D
  14747   "RTN","VPR DJ09",118, 0)
  14748    ... Q:DAT E<VPRSTART   Q:DATE>V PRSTOP  S  IDT=999999 9-DATE
  14749   "RTN","VPR DJ09",119, 0)
  14750    ... S DA= 0 F  S DA= $O(^PXRMIN DX(FNUM,"P PI",+$G(DF N),TYPE,IT EM,DATE,DA )) Q:DA<1   S ^TMP("V PRPX",$J,I DT,DA)=ITE M_U_DATE
  14751   "RTN","VPR DJ09",120, 0)
  14752    Q
  14753   "RTN","VPR DJ09",121, 0)
  14754   PTF ; from  ^PXRMINDX (45,"ICD9" ,"PNI",DFN ,TYPE,ITEM ,DATE,DA)
  14755   "RTN","VPR DJ09",122, 0)
  14756    S TYPE=""  F  S TYPE =$O(^PXRMI NDX(45,"IC D9","PNI", +$G(DFN),T YPE)) Q:TY PE=""  D
  14757   "RTN","VPR DJ09",123, 0)
  14758    . S ITEM= 0 F  S ITE M=$O(^PXRM INDX(45,"I CD9","PNI" ,+$G(DFN), TYPE,ITEM) ) Q:ITEM<1   D
  14759   "RTN","VPR DJ09",124, 0)
  14760    .. S DATE =0 F  S DA TE=$O(^PXR MINDX(45," ICD9","PNI ",+$G(DFN) ,TYPE,ITEM ,DATE)) Q: DATE<1  D
  14761   "RTN","VPR DJ09",125, 0)
  14762    ... Q:DAT E<VPRSTART   Q:DATE>V PRSTOP  S  IDT=999999 9-DATE
  14763   "RTN","VPR DJ09",126, 0)
  14764    ... S DA= "" F  S DA =$O(^PXRMI NDX(45,"IC D9","PNI", +$G(DFN),T YPE,ITEM,D ATE,DA)) Q :DA=""  S  ^TMP("VPRP X",$J,IDT, DA_";"_TYP E)=ITEM_U_ DATE
  14765   "RTN","VPR DJ09",127, 0)
  14766    Q
  14767   "RTN","VPR DJ09M")
  14768   0^65^B1020 4859
  14769   "RTN","VPR DJ09M",1,0 )
  14770   VPRDJ09M ; SLC/MKB --  Mental He alth ;9/9/ 13 4:51pm
  14771   "RTN","VPR DJ09M",2,0 )
  14772    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  14773   "RTN","VPR DJ09M",3,0 )
  14774    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  14775   "RTN","VPR DJ09M",4,0 )
  14776    ;
  14777   "RTN","VPR DJ09M",5,0 )
  14778    ; All tag s expect D FN, ID, [V PRSTART, V PRSTOP, VP RMAX, VPRT EXT]
  14779   "RTN","VPR DJ09M",6,0 )
  14780    ;
  14781   "RTN","VPR DJ09M",7,0 )
  14782    ;
  14783   "RTN","VPR DJ09M",8,0 )
  14784   MH ; -- Me ntal Healt h Administ rations [f rom ^VPRDJ 0]
  14785   "RTN","VPR DJ09M",9,0 )
  14786    I $G(VPRI D) D MH1(V PRID) Q
  14787   "RTN","VPR DJ09M",10, 0)
  14788    N CNT,VPR IDT,ID,FNU M,TOTAL,VP ROUT,VPRYS ,IEN
  14789   "RTN","VPR DJ09M",11, 0)
  14790    ;
  14791   "RTN","VPR DJ09M",12, 0)
  14792    S IEN=0 F   S IEN=$O (^YTT(601. 71,IEN)) Q :IEN'>0  D
  14793   "RTN","VPR DJ09M",13, 0)
  14794    .S VPRYS( "CODE")=IE N,VPRYS("D FN")=+$G(D FN),VPRYS( "LIMIT")=9 99
  14795   "RTN","VPR DJ09M",14, 0)
  14796    .K VPROUT
  14797   "RTN","VPR DJ09M",15, 0)
  14798    .D PTTEST ^YTQPXRM2( .VPROUT,.V PRYS)
  14799   "RTN","VPR DJ09M",16, 0)
  14800    .I VPROUT (1)["[ERRO R]" Q
  14801   "RTN","VPR DJ09M",17, 0)
  14802    .S TOTAL= $P(VPROUT( 1),U,2)+1
  14803   "RTN","VPR DJ09M",18, 0)
  14804    .I $P(VPR OUT(1),U,2 )<1 Q
  14805   "RTN","VPR DJ09M",19, 0)
  14806    .;S CNT=1  F  S CNT= $O(VPROUT( CNT)) Q:CN T'>0  D
  14807   "RTN","VPR DJ09M",20, 0)
  14808    .F CNT=2: 1:TOTAL D
  14809   "RTN","VPR DJ09M",21, 0)
  14810    ..I $G(VP ROUT(CNT)) ="" Q
  14811   "RTN","VPR DJ09M",22, 0)
  14812    ..S ID=$P (VPROUT(CN T),U)
  14813   "RTN","VPR DJ09M",23, 0)
  14814    ..D MH1(I D,IEN)
  14815   "RTN","VPR DJ09M",24, 0)
  14816    ;handle o ld MH test  before th e lastest  revision t o their pa ckage
  14817   "RTN","VPR DJ09M",25, 0)
  14818    ;S FNUM=6 01.2 D SOR T^VPRDJ09  ;sort ^PXR MINDX into  ^TMP("VPR PX",$J,IDT )
  14819   "RTN","VPR DJ09M",26, 0)
  14820    ;S VPRIDT =0 F  S VP RIDT=$O(^T MP("VPRPX" ,$J,VPRIDT )) Q:VPRID T<1  D  Q: VPRI'<VPRM AX
  14821   "RTN","VPR DJ09M",27, 0)
  14822    ;. S ID=0  F  S ID=$ O(^TMP("VP RPX",$J,VP RIDT,ID))  Q:ID<1  D  YT1^VPRDJ0 9(ID) Q:VP RI'<VPRMAX
  14823   "RTN","VPR DJ09M",28, 0)
  14824    ;I VPRI'< VPRMAX Q
  14825   "RTN","VPR DJ09M",29, 0)
  14826    ;handle n ew MH test   after re vision to  their pack age
  14827   "RTN","VPR DJ09M",30, 0)
  14828    ;S FNUM=6 01.84 D SO RT^VPRDJ09  ;sort ^PX RMINDX int o ^TMP("VP RPX",$J,ID T)
  14829   "RTN","VPR DJ09M",31, 0)
  14830    ;S VPRIDT =0 F  S VP RIDT=$O(^T MP("VPRPX" ,$J,VPRIDT )) Q:VPRID T<1  D  Q: VPRI'<VPRM AX
  14831   "RTN","VPR DJ09M",32, 0)
  14832    ;. S ID=0  F  S ID=$ O(^TMP("VP RPX",$J,VP RIDT,ID))  Q:ID<1  D  YT1^VPRDJ0 9(ID) Q:VP RI'<VPRMAX
  14833   "RTN","VPR DJ09M",33, 0)
  14834    K ^TMP("V PRPX",$J)
  14835   "RTN","VPR DJ09M",34, 0)
  14836    Q
  14837   "RTN","VPR DJ09M",35, 0)
  14838    ;
  14839   "RTN","VPR DJ09M",36, 0)
  14840   MH1(ID,IEN ) ; -- MH  Administra tion
  14841   "RTN","VPR DJ09M",37, 0)
  14842    N VPRY,CO PY,GBL,ISC OPY,MH,NAM E,NODE,CNT ,I,X2,X,Y, TEMP,TEXT
  14843   "RTN","VPR DJ09M",38, 0)
  14844    D ENDAS71 ^YTQPXRM6( .VPRY,ID)
  14845   "RTN","VPR DJ09M",39, 0)
  14846    ;
  14847   "RTN","VPR DJ09M",40, 0)
  14848    S NAME=$P ($G(^YTT(6 01.71,IEN, 0)),U)
  14849   "RTN","VPR DJ09M",41, 0)
  14850    S COPY=$G (^YTT(601. 71,IEN,7))
  14851   "RTN","VPR DJ09M",42, 0)
  14852    S ISCOPY= +$P($G(^YT T(601.71,I EN,8)),U,5 )
  14853   "RTN","VPR DJ09M",43, 0)
  14854    S MH("loc alId")=ID, X2=$G(VPRY (2))
  14855   "RTN","VPR DJ09M",44, 0)
  14856    S MH("uid ")=$$SETUI D^VPRUTILS ("mh",DFN, ID)
  14857   "RTN","VPR DJ09M",45, 0)
  14858    S MH("dis playName") =$P(X2,U,2 ),MH("name ")=$S(NAME '="":NAME, 1:$P(X2,U, 3))
  14859   "RTN","VPR DJ09M",46, 0)
  14860    S MH("adm inisteredD ateTime")= $$JSONDT^V PRUTILS($P (X2,U,4))
  14861   "RTN","VPR DJ09M",47, 0)
  14862    S X=$P(X2 ,U,6) I $L (X) D  ;or dered by
  14863   "RTN","VPR DJ09M",48, 0)
  14864    . S Y=+$O (^VA(200," B",X,0)),M H("provide rName")=X
  14865   "RTN","VPR DJ09M",49, 0)
  14866    . S:Y MH( "providerU id")=$$SET UID^VPRUTI LS("user", ,Y)
  14867   "RTN","VPR DJ09M",50, 0)
  14868    ;get ques tions/answ ers for te st
  14869   "RTN","VPR DJ09M",51, 0)
  14870    S I=0,CNT =0 F  S I= $O(VPRY("R ",I)) Q:I' >0  D
  14871   "RTN","VPR DJ09M",52, 0)
  14872    .S NODE=$ G(VPRY("R" ,I))
  14873   "RTN","VPR DJ09M",53, 0)
  14874    .S CNT=CN T+1
  14875   "RTN","VPR DJ09M",54, 0)
  14876    .K TEMP,^ TMP($J,"VP R MH TEXT" )
  14877   "RTN","VPR DJ09M",55, 0)
  14878    .;answers
  14879   "RTN","VPR DJ09M",56, 0)
  14880    .S TEMP=$ P(NODE,U,2 ) I TEMP>0  D
  14881   "RTN","VPR DJ09M",57, 0)
  14882    ..S MH("r esponses", CNT,"answe r","uid")= $$SETVURN^ VPRUTILS(" mha-answer ",TEMP)
  14883   "RTN","VPR DJ09M",58, 0)
  14884    ..S MH("r esponses", CNT,"answe r","text") =$P(NODE,U ,6)
  14885   "RTN","VPR DJ09M",59, 0)
  14886    .;questio ns
  14887   "RTN","VPR DJ09M",60, 0)
  14888    .S TEMP=$ P(NODE,U,3 ) I TEMP>0  D
  14889   "RTN","VPR DJ09M",61, 0)
  14890    ..S MH("r esponses", CNT,"quest ion","uid" )=$$SETVUR N^VPRUTILS ("mha-ques tion",TEMP )
  14891   "RTN","VPR DJ09M",62, 0)
  14892    ..S GBL=$ NA(^YTT(60 1.72,TEMP, 1))
  14893   "RTN","VPR DJ09M",63, 0)
  14894    ..D SETTE XT^VPRUTIL S(GBL,$NA( ^TMP($J,"V PR MH TEXT ")))
  14895   "RTN","VPR DJ09M",64, 0)
  14896    ..M MH("r esponses", CNT,"quest ion","text ","\")=^TM P($J,"VPR  MH TEXT")
  14897   "RTN","VPR DJ09M",65, 0)
  14898    ; get sca le(s) for  test
  14899   "RTN","VPR DJ09M",66, 0)
  14900    S I=0,CNT =0 F  S I= $O(VPRY("S I",I)) Q:I '>0  D
  14901   "RTN","VPR DJ09M",67, 0)
  14902    .S NODE=$ G(VPRY("SI ",I))
  14903   "RTN","VPR DJ09M",68, 0)
  14904    .S CNT=CN T+1
  14905   "RTN","VPR DJ09M",69, 0)
  14906    .S MH("sc ales",CNT, "scale","u id")=$$SET VURN^VPRUT ILS("mha-s cale",I)
  14907   "RTN","VPR DJ09M",70, 0)
  14908    .S MH("sc ales",CNT, "scale","n ame")=$P(N ODE,U,2)
  14909   "RTN","VPR DJ09M",71, 0)
  14910    .S MH("sc ales",CNT, "scale","r awScore")= $P(NODE,U, 3)
  14911   "RTN","VPR DJ09M",72, 0)
  14912    .I $P(NOD E,U,4)'=""  S MH("sca les",CNT," scale","tr ansformSco re")=$P(NO DE,U,4)
  14913   "RTN","VPR DJ09M",73, 0)
  14914    S MH("isC opyright") =$S(ISCOPY =1:"true", 1:"false")
  14915   "RTN","VPR DJ09M",74, 0)
  14916    I ISCOPY= 1 S MH("co pyrightTex t")=COPY
  14917   "RTN","VPR DJ09M",75, 0)
  14918    D ADD^VPR DJ("MH","m h")
  14919   "RTN","VPR DJ09M",76, 0)
  14920    Q
  14921   "RTN","VPR DJ1")
  14922   0^50^B1814 9314
  14923   "RTN","VPR DJ1",1,0)
  14924   VPRDJ1 ;SL C/MKB -- V PR Patient  Object RP Cs ; 11/2/ 12 5:45pm
  14925   "RTN","VPR DJ1",2,0)
  14926    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  14927   "RTN","VPR DJ1",3,0)
  14928    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  14929   "RTN","VPR DJ1",4,0)
  14930    ;
  14931   "RTN","VPR DJ1",5,0)
  14932    ;
  14933   "RTN","VPR DJ1",6,0)
  14934   PUT(VPR,PA T,TYPE,JSO N) ; -- Sa ve/update  JSON OBJEC T in ^VPR( 560.1), re turn UID i f successf ul
  14935   "RTN","VPR DJ1",7,0)
  14936    ; RPC = V PR PUT PAT IENT DATA
  14937   "RTN","VPR DJ1",8,0)
  14938    ;
  14939   "RTN","VPR DJ1",9,0)
  14940    N ARRAY,C NT,ERR,VPR ERR,UID,DA ,X,I,DFN,V PRSYS
  14941   "RTN","VPR DJ1",10,0)
  14942    ;M JSON=I NPUT(0)
  14943   "RTN","VPR DJ1",11,0)
  14944    D DECODE^ VPRJSON("J SON","ARRA Y","VPRERR ")
  14945   "RTN","VPR DJ1",12,0)
  14946    ;N XCNT S  XCNT=$O(^ XTMP("AGPA RRAY",""), -1),XCNT=X CNT+1
  14947   "RTN","VPR DJ1",13,0)
  14948    ;M ^XTMP( "AGPARRAY" ,XCNT,"DAT A")=ARRAY
  14949   "RTN","VPR DJ1",14,0)
  14950    ;S ^XTMP( "AGPARRAY" ,XCNT,"TYP E")=TYPE
  14951   "RTN","VPR DJ1",15,0)
  14952    ;M ^XTMP( "AGPARRAY" )=ARRAY
  14953   "RTN","VPR DJ1",16,0)
  14954    I $D(VPRE RR) D  Q   ;S X=$G(ER R(1)) K ER R S ERR=X  G PTQ
  14955   "RTN","VPR DJ1",17,0)
  14956    . K ARRAY  N VPRTMP, VPRTXT
  14957   "RTN","VPR DJ1",18,0)
  14958    . S VPRTX T(1)="Prob lem decodi ng json in put."
  14959   "RTN","VPR DJ1",19,0)
  14960    . D SETER ROR^VPRUTI LS(.VPRTMP ,.VPRERR,. VPRTXT,.JS ON)
  14961   "RTN","VPR DJ1",20,0)
  14962    . K VPRER R D ENCODE ^VPRJSON(" VPRTMP","A RRAY","VPR ERR")
  14963   "RTN","VPR DJ1",21,0)
  14964    . S VPR(. 5)="{""api Version"": ""1.01""," "error"":{ "
  14965   "RTN","VPR DJ1",22,0)
  14966    . M VPR(1 )=ARRAY
  14967   "RTN","VPR DJ1",23,0)
  14968    . S VPR(2 )="}}"
  14969   "RTN","VPR DJ1",24,0)
  14970    ;
  14971   "RTN","VPR DJ1",25,0)
  14972    S UID=$G( ARRAY("uid ")),VPRSYS =$$GET^XPA R("SYS","V PR SYSTEM  NAME")
  14973   "RTN","VPR DJ1",26,0)
  14974    I $L(UID)  S DA=+$O( ^VPR(560.1 ,"B",UID,0 )) I DA<1  S ERR=$$ER R(3,UID) G  PTQ
  14975   "RTN","VPR DJ1",27,0)
  14976    I '$L(UID ) D  G:$D( ERR) PTQ Q :$D(VPRERR )
  14977   "RTN","VPR DJ1",28,0)
  14978    . D NEW Q :$D(ERR)
  14979   "RTN","VPR DJ1",29,0)
  14980    . S ARRAY ("uid")=UI D K JSON
  14981   "RTN","VPR DJ1",30,0)
  14982    . D ENCOD E^VPRJSON( "ARRAY","J SON","VPRE RR")
  14983   "RTN","VPR DJ1",31,0)
  14984    . I $D(VP RERR) D  Q   ;S X=$G( ERR(1)) K  ERR S ERR= X Q
  14985   "RTN","VPR DJ1",32,0)
  14986    .. K JSON  N VPRTMP, VPRTXT
  14987   "RTN","VPR DJ1",33,0)
  14988    .. S VPRT XT(1)="Pro blem encod ing json o utput."
  14989   "RTN","VPR DJ1",34,0)
  14990    .. D SETE RROR^VPRUT ILS(.VPRTM P,.VPRERR, .VPRTXT,.A RRAY)
  14991   "RTN","VPR DJ1",35,0)
  14992    .. K VPRE RR D ENCOD E^VPRJSON( "VPRTMP"," JSON","VPR ERR")
  14993   "RTN","VPR DJ1",36,0)
  14994    .. S VPR( .5)="{""ap iVersion"" :""1.01"", ""error"": {"
  14995   "RTN","VPR DJ1",37,0)
  14996    .. M VPR( 1)=JSON
  14997   "RTN","VPR DJ1",38,0)
  14998    .. S VPR( 2)="}}"
  14999   "RTN","VPR DJ1",39,0)
  15000    ;
  15001   "RTN","VPR DJ1",40,0)
  15002    K ^VPR(56 0.1,DA,1)  S ^(1,0)=" ^560.101^^ ",CNT=0
  15003   "RTN","VPR DJ1",41,0)
  15004    S I="" F   S I=$O(JS ON(I)) Q:I =""  S CNT =CNT+1,^VP R(560.1,DA ,1,CNT,0)= JSON(I)
  15005   "RTN","VPR DJ1",42,0)
  15006    S:$G(CNT)  ^VPR(560. 1,DA,1,0)= "^560.101^ "_CNT_U_CN T
  15007   "RTN","VPR DJ1",43,0)
  15008    ;
  15009   "RTN","VPR DJ1",44,0)
  15010   PTQ ; add  item count  and termi nating cha racters
  15011   "RTN","VPR DJ1",45,0)
  15012    I $D(ERR)  S VPR="{" "apiVersio n"":""1.01 "",""error "":{""mess age"":"""_ ERR_"""}," "success"" :false}" Q
  15013   "RTN","VPR DJ1",46,0)
  15014    S VPR="{" "apiVersio n"":""1.01 "",""data" ":{""updat ed"":"_""" "_$$HL7NOW _""""_","" uid"":"""_ UID_"""}," "success"" :true}"
  15015   "RTN","VPR DJ1",47,0)
  15016    S DFN=+$P (UID,":",5 )
  15017   "RTN","VPR DJ1",48,0)
  15018    D POST^VP REVNT(DFN, TYPE,DA) ; UID)
  15019   "RTN","VPR DJ1",49,0)
  15020    Q
  15021   "RTN","VPR DJ1",50,0)
  15022    ;
  15023   "RTN","VPR DJ1",51,0)
  15024   NEW ; -- c reate new  entry in ^ VPR(560.1)  from PAT, TYPE,VPRSY S
  15025   "RTN","VPR DJ1",52,0)
  15026    ;  Return  UID & DA,  or ERR
  15027   "RTN","VPR DJ1",53,0)
  15028    N DFN,ICN
  15029   "RTN","VPR DJ1",54,0)
  15030    S DFN=+$G (PAT),ICN= "",TYPE=$G (TYPE)
  15031   "RTN","VPR DJ1",55,0)
  15032    I DFN<1,D FN[";" S I CN=+$P($G( DFN),";",2 ),DFN=+$G( DFN)
  15033   "RTN","VPR DJ1",56,0)
  15034    I DFN<1,I CN S DFN=+ $$GETDFN^M PIF001(ICN )
  15035   "RTN","VPR DJ1",57,0)
  15036    I DFN<1!' $D(^DPT(DF N)) S ERR= $$ERR(1,DF N) Q
  15037   "RTN","VPR DJ1",58,0)
  15038    I TYPE=""  S ERR=$$E RR(2,"null ") Q
  15039   "RTN","VPR DJ1",59,0)
  15040    ;
  15041   "RTN","VPR DJ1",60,0)
  15042    S DA=$$NE XTIFN I DA <1 S ERR=$ $ERR(4) Q
  15043   "RTN","VPR DJ1",61,0)
  15044    S UID="ur n:va:"_TYP E_":"_VPRS YS_":"_DFN _":"_DA
  15045   "RTN","VPR DJ1",62,0)
  15046    S ^VPR(56 0.1,DA,0)= UID_U_DFN_ U_TYPE
  15047   "RTN","VPR DJ1",63,0)
  15048    S ^VPR(56 0.1,"B",UI D,DA)=""
  15049   "RTN","VPR DJ1",64,0)
  15050    S ^VPR(56 0.1,"C",DF N,TYPE,DA) =""
  15051   "RTN","VPR DJ1",65,0)
  15052    Q
  15053   "RTN","VPR DJ1",66,0)
  15054    ;
  15055   "RTN","VPR DJ1",67,0)
  15056   NEXTIFN()  ; -- Retur ns next av ailable IF N
  15057   "RTN","VPR DJ1",68,0)
  15058    N I,HDR,T OTAL,DA
  15059   "RTN","VPR DJ1",69,0)
  15060    L +^VPR(5 60.1,0):$S ($G(DILOCK TM)>0:DILO CKTM,1:5)
  15061   "RTN","VPR DJ1",70,0)
  15062    I '$T Q " ^"
  15063   "RTN","VPR DJ1",71,0)
  15064    S HDR=$G( ^VPR(560.1 ,0)),TOTAL =+$P(HDR,U ,4),I=$O(^ VPR(560.1, "?"),-1)
  15065   "RTN","VPR DJ1",72,0)
  15066    F I=(I+1) :1 Q:'$D(^ VPR(560.1, I,0))
  15067   "RTN","VPR DJ1",73,0)
  15068    S DA=I,$P (HDR,U,3,4 )=DA_U_(TO TAL+1) S ^ VPR(560.1, 0)=HDR
  15069   "RTN","VPR DJ1",74,0)
  15070    L -^VPR(5 60.1,0)
  15071   "RTN","VPR DJ1",75,0)
  15072    Q DA
  15073   "RTN","VPR DJ1",76,0)
  15074    ;
  15075   "RTN","VPR DJ1",77,0)
  15076   ERR(X,VAL)  ; -- retu rn error m essage
  15077   "RTN","VPR DJ1",78,0)
  15078    N MSG  S  MSG="Error "
  15079   "RTN","VPR DJ1",79,0)
  15080    I X=1  S  MSG="Patie nt with df n '"_$G(VA L)_"' not  found"
  15081   "RTN","VPR DJ1",80,0)
  15082    I X=2  S  MSG="Domai n type '"_ $G(VAL)_"'  not recog nized"
  15083   "RTN","VPR DJ1",81,0)
  15084    I X=3  S  MSG="UID ' "_$G(VAL)_ "' not fou nd"
  15085   "RTN","VPR DJ1",82,0)
  15086    I X=4  S  MSG="Unabl e to creat e new obje ct"
  15087   "RTN","VPR DJ1",83,0)
  15088    I X=99 S  MSG="Unkno wn request "
  15089   "RTN","VPR DJ1",84,0)
  15090    Q MSG
  15091   "RTN","VPR DJ1",85,0)
  15092    ;
  15093   "RTN","VPR DJ1",86,0)
  15094   HL7NOW() ;  -- Return  current t ime in HL7  format
  15095   "RTN","VPR DJ1",87,0)
  15096    Q $P($$FM THL7^XLFDT ($$NOW^XLF DT),"-")
  15097   "RTN","VPR DJ1",88,0)
  15098    ;
  15099   "RTN","VPR DJ1",89,0)
  15100   CONV ; --  convert ui d format
  15101   "RTN","VPR DJ1",90,0)
  15102    N DA,X0,U ID,VPRSYS, DFN,COLL,N EW,I,JSON, VPRY,ERR,C NT
  15103   "RTN","VPR DJ1",91,0)
  15104    S VPRSYS= $$GET^XPAR ("SYS","VP R SYSTEM N AME")
  15105   "RTN","VPR DJ1",92,0)
  15106    S DA=0 F   S DA=$O(^ VPR(560.1, DA)) Q:DA< 1  D
  15107   "RTN","VPR DJ1",93,0)
  15108    . S X0=$G (^VPR(560. 1,DA,0)),U ID=$P(X0,U )
  15109   "RTN","VPR DJ1",94,0)
  15110    . K ^VPR( 560.1,"B", UID,DA),JS ON
  15111   "RTN","VPR DJ1",95,0)
  15112    . S DFN=$ P(X0,"^",2 ),COLL=$P( X0,"^",3)
  15113   "RTN","VPR DJ1",96,0)
  15114    . S NEW=" urn:va:"_C OLL_":"_VP RSYS_":"_D FN_":"_DA
  15115   "RTN","VPR DJ1",97,0)
  15116    . S $P(^V PR(560.1,D A,0),U)=NE W,^VPR(560 .1,"B",NEW ,DA)=""
  15117   "RTN","VPR DJ1",98,0)
  15118    . ;decode  JSON obje ct, reset  uid
  15119   "RTN","VPR DJ1",99,0)
  15120    . S I=0 F   S I=$O(^ VPR(560.1, DA,1,I)) Q :I<1  S JS ON(I)=$G(^ (I,0))
  15121   "RTN","VPR DJ1",100,0 )
  15122    . Q:'$D(J SON)  K VP RY,ERR
  15123   "RTN","VPR DJ1",101,0 )
  15124    . D DECOD E^VPRJSON( "JSON","VP RY","ERR")  I $D(ERR)  W !,DA Q
  15125   "RTN","VPR DJ1",102,0 )
  15126    . S VPRY( "uid")=NEW  K JSON
  15127   "RTN","VPR DJ1",103,0 )
  15128    . D ENCOD E^VPRJSON( "VPRY","JS ON","ERR")  I $D(ERR)  W !,DA Q
  15129   "RTN","VPR DJ1",104,0 )
  15130    . K ^VPR( 560.1,DA,1 ) S ^(1,0) ="^560.101 ^^",CNT=0
  15131   "RTN","VPR DJ1",105,0 )
  15132    . S I=""  F  S I=$O( JSON(I)) Q :I=""  S C NT=CNT+1,^ VPR(560.1, DA,1,CNT,0 )=JSON(I)
  15133   "RTN","VPR DJ1",106,0 )
  15134    . S:$G(CN T) ^VPR(56 0.1,DA,1,0 )="^560.10 1^"_CNT_U_ CNT
  15135   "RTN","VPR DJ1",107,0 )
  15136    Q
  15137   "RTN","VPR DJ2")
  15138   0^51^B2110 0510
  15139   "RTN","VPR DJ2",1,0)
  15140   VPRDJ2 ;SL C/MKB -- V PR Object  RPCs ; 1/1 8/13 3:54p m
  15141   "RTN","VPR DJ2",2,0)
  15142    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  15143   "RTN","VPR DJ2",3,0)
  15144    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  15145   "RTN","VPR DJ2",4,0)
  15146    ;
  15147   "RTN","VPR DJ2",5,0)
  15148    ;
  15149   "RTN","VPR DJ2",6,0)
  15150   GET(VPR,FI LTER) ; --  Return se arch resul ts as JSON  in @VPR@( n)
  15151   "RTN","VPR DJ2",7,0)
  15152    ; RPC = V PR GET OBJ ECT
  15153   "RTN","VPR DJ2",8,0)
  15154    N TYPE,VP RMAX,VPRI, VPRID,VPRE RR,IEN
  15155   "RTN","VPR DJ2",9,0)
  15156    S VPR=$NA (^TMP("VPR ",$J)),VPR I=0 K @VPR
  15157   "RTN","VPR DJ2",10,0)
  15158    ;
  15159   "RTN","VPR DJ2",11,0)
  15160    ; parse &  validate  input para meters
  15161   "RTN","VPR DJ2",12,0)
  15162    S TYPE=$G (FILTER("c ollection" )),TYPE=$$ LOW^XLFSTR (TYPE)
  15163   "RTN","VPR DJ2",13,0)
  15164    S VPRMAX= +$G(FILTER ("max"),99 99) ;??
  15165   "RTN","VPR DJ2",14,0)
  15166    S VPRID=$ G(FILTER(" id"))
  15167   "RTN","VPR DJ2",15,0)
  15168    ;
  15169   "RTN","VPR DJ2",16,0)
  15170    ;set erro r trap
  15171   "RTN","VPR DJ2",17,0)
  15172    N $ES,$ET ,ERRARRY,E RRDOM,ERRP AT,ERRMSG
  15173   "RTN","VPR DJ2",18,0)
  15174    ;S $ET="D  ERRHDLR^V PRDERRH G  ERRQ^VPRDJ 0"
  15175   "RTN","VPR DJ2",19,0)
  15176    S ERRDOM= "vpr",ERRM SG=$G(TYPE )
  15177   "RTN","VPR DJ2",20,0)
  15178    K ^TMP($J ,"VPR ERRO R")
  15179   "RTN","VPR DJ2",21,0)
  15180    ;
  15181   "RTN","VPR DJ2",22,0)
  15182    ; extract  data
  15183   "RTN","VPR DJ2",23,0)
  15184    I $L(VPRI D) D  G GQ
  15185   "RTN","VPR DJ2",24,0)
  15186    . S IEN=+ VPRID I 'I EN S IEN=+ $O(^VPR(56 0.11,"B",V PRID,0)) ; IEN or UID
  15187   "RTN","VPR DJ2",25,0)
  15188    . D:IEN V PR1^VPRDJ0 2(560.11,I EN)
  15189   "RTN","VPR DJ2",26,0)
  15190    I TYPE=""  S VPRERR= "Missing o r invalid  collection  type" G G Q
  15191   "RTN","VPR DJ2",27,0)
  15192    S IEN=0 F   S IEN=$O (^VPR(560. 11,"C",TYP E,IEN)) Q: IEN<1  D V PR1^VPRDJ0 2(560.11,I EN)
  15193   "RTN","VPR DJ2",28,0)
  15194    ;
  15195   "RTN","VPR DJ2",29,0)
  15196   GQ ;build  return JSO N
  15197   "RTN","VPR DJ2",30,0)
  15198    D GTQ^VPR DJ
  15199   "RTN","VPR DJ2",31,0)
  15200    Q
  15201   "RTN","VPR DJ2",32,0)
  15202    ;
  15203   "RTN","VPR DJ2",33,0)
  15204   DEL(VPR,VP RID) ; --  Delete obj ect VPRID  from ^VPR( 560.11)
  15205   "RTN","VPR DJ2",34,0)
  15206    ; RPC = V PR DELETE  OBJECT
  15207   "RTN","VPR DJ2",35,0)
  15208    ;
  15209   "RTN","VPR DJ2",36,0)
  15210    N ACTION, ERR,UID,DA ,DIK,TYPE
  15211   "RTN","VPR DJ2",37,0)
  15212    S UID=$G( VPRID) I ' $L(UID) S  ERR=$$ERR( 3,"null")  G PTQ
  15213   "RTN","VPR DJ2",38,0)
  15214    S DA=+$O( ^VPR(560.1 1,"B",UID, 0)) I DA<1  S ERR=$$E RR(3,UID)  G PTQ
  15215   "RTN","VPR DJ2",39,0)
  15216    S DIK="^V PR(560.11, " D ^DIK
  15217   "RTN","VPR DJ2",40,0)
  15218    S ACTION= "@",TYPE=$ P(UID,":", 3)
  15219   "RTN","VPR DJ2",41,0)
  15220    G PTQ
  15221   "RTN","VPR DJ2",42,0)
  15222    Q
  15223   "RTN","VPR DJ2",43,0)
  15224    ;
  15225   "RTN","VPR DJ2",44,0)
  15226   PUT(VPR,TY PE,JSON) ;  -- Save/u pdate JSON  OBJECT in  ^VPR(560. 11), retur n UID if s uccessful
  15227   "RTN","VPR DJ2",45,0)
  15228    ; RPC = V PR PUT OBJ ECT
  15229   "RTN","VPR DJ2",46,0)
  15230    ;
  15231   "RTN","VPR DJ2",47,0)
  15232    N ACTION, ARRAY,CNT, ERR,VPRERR ,UID,DA,X, I,VPRSYS
  15233   "RTN","VPR DJ2",48,0)
  15234    D DECODE^ VPRJSON("J SON","ARRA Y","VPRERR ")
  15235   "RTN","VPR DJ2",49,0)
  15236    ;N XCNT S  XCNT=$O(^ XTMP("AGPA RRAY",""), -1),XCNT=X CNT+1
  15237   "RTN","VPR DJ2",50,0)
  15238    ;M ^XTMP( "AGPARRAY" ,XCNT,"DAT A")=ARRAY
  15239   "RTN","VPR DJ2",51,0)
  15240    ;S ^XTMP( "AGPARRAY" ,XCNT,"TYP E")=TYPE
  15241   "RTN","VPR DJ2",52,0)
  15242    I $D(VPRE RR) D  Q   ;S X=$G(ER R(1)) K ER R S ERR=X  G PTQ
  15243   "RTN","VPR DJ2",53,0)
  15244    . K ARRAY  N VPRTMP, VPRTXT
  15245   "RTN","VPR DJ2",54,0)
  15246    . S VPRTX T(1)="Prob lem decodi ng json in put."
  15247   "RTN","VPR DJ2",55,0)
  15248    . D SETER ROR^VPRUTI LS(.VPRTMP ,.VPRERR,. VPRTXT,.JS ON)
  15249   "RTN","VPR DJ2",56,0)
  15250    . K VPRER R D ENCODE ^VPRJSON(" VPRTMP","A RRAY","VPR ERR")
  15251   "RTN","VPR DJ2",57,0)
  15252    . S VPR(. 5)="{""api Version"": ""1.01""," "error"":{ "
  15253   "RTN","VPR DJ2",58,0)
  15254    . M VPR(1 )=ARRAY
  15255   "RTN","VPR DJ2",59,0)
  15256    . S VPR(2 )="}}"
  15257   "RTN","VPR DJ2",60,0)
  15258    ;
  15259   "RTN","VPR DJ2",61,0)
  15260    S UID=$G( ARRAY("uid ")),VPRSYS =$$GET^XPA R("SYS","V PR SYSTEM  NAME")
  15261   "RTN","VPR DJ2",62,0)
  15262    I $L(UID)  S DA=+$O( ^VPR(560.1 1,"B",UID, 0)) I DA<1  S ERR=$$E RR(3,UID)  G PTQ
  15263   "RTN","VPR DJ2",63,0)
  15264    ;I $L(UID ) S DA=+$O (^VPR(560. 11,"B",UID ,0)) I DA< 1 D NEW1(U ID)
  15265   "RTN","VPR DJ2",64,0)
  15266    I '$L(UID ) D  G:$D( ERR) PTQ Q :$D(VPRERR )
  15267   "RTN","VPR DJ2",65,0)
  15268    . D NEW Q :$D(ERR)
  15269   "RTN","VPR DJ2",66,0)
  15270    . S ARRAY ("uid")=UI D K JSON
  15271   "RTN","VPR DJ2",67,0)
  15272    . D ENCOD E^VPRJSON( "ARRAY","J SON","VPRE RR")
  15273   "RTN","VPR DJ2",68,0)
  15274    . I $D(VP RERR) D  Q   ;S X=$G( ERR(1)) K  ERR S ERR= X Q
  15275   "RTN","VPR DJ2",69,0)
  15276    .. K JSON  N VPRTMP, VPRTXT
  15277   "RTN","VPR DJ2",70,0)
  15278    .. S VPRT XT(1)="Pro blem encod ing json o utput."
  15279   "RTN","VPR DJ2",71,0)
  15280    .. D SETE RROR^VPRUT ILS(.VPRTM P,.VPRERR, .VPRTXT,.A RRAY)
  15281   "RTN","VPR DJ2",72,0)
  15282    .. K VPRE RR D ENCOD E^VPRJSON( "VPRTMP"," JSON","VPR ERR")
  15283   "RTN","VPR DJ2",73,0)
  15284    .. S VPR( .5)="{""ap iVersion"" :""1.01"", ""error"": {"
  15285   "RTN","VPR DJ2",74,0)
  15286    .. M VPR( 1)=JSON
  15287   "RTN","VPR DJ2",75,0)
  15288    .. S VPR( 2)="}}"
  15289   "RTN","VPR DJ2",76,0)
  15290    ;
  15291   "RTN","VPR DJ2",77,0)
  15292    K ^VPR(56 0.11,DA,1)  S ^(1,0)= "^560.111^ ^",CNT=0
  15293   "RTN","VPR DJ2",78,0)
  15294    S I="" F   S I=$O(JS ON(I)) Q:I =""  S CNT =CNT+1,^VP R(560.11,D A,1,CNT,0) =JSON(I)
  15295   "RTN","VPR DJ2",79,0)
  15296    S:$G(CNT)  ^VPR(560. 11,DA,1,0) ="^560.111 ^"_CNT_U_C NT
  15297   "RTN","VPR DJ2",80,0)
  15298    ;
  15299   "RTN","VPR DJ2",81,0)
  15300   PTQ ; add  item count  and termi nating cha racters
  15301   "RTN","VPR DJ2",82,0)
  15302    I $D(ERR)  S VPR="{" "apiVersio n"":""1.01 "",""error "":{""mess age"":"""_ ERR_"""}," "success"" :false}" Q
  15303   "RTN","VPR DJ2",83,0)
  15304    S VPR="{" "apiVersio n"":""1.01 "",""data" ":{""updat ed"":"_""" "_$$HL7NOW _""""_","" uid"":"""_ UID_"""}," "success"" :true}"
  15305   "RTN","VPR DJ2",84,0)
  15306    D POSTX^V PREVNT(TYP E,DA,$G(AC TION)) ;UI D)
  15307   "RTN","VPR DJ2",85,0)
  15308    Q
  15309   "RTN","VPR DJ2",86,0)
  15310    ;
  15311   "RTN","VPR DJ2",87,0)
  15312   NEW1(UID)  ; -- creat e new entr y in ^VPR( 560.11) fr om PAT,TYP E,VPRSYS
  15313   "RTN","VPR DJ2",88,0)
  15314    ;  Return  UID & DA,  or ERR
  15315   "RTN","VPR DJ2",89,0)
  15316    S TYPE=$G (TYPE)
  15317   "RTN","VPR DJ2",90,0)
  15318    I TYPE=""  S ERR=$$E RR(2,"null ") Q
  15319   "RTN","VPR DJ2",91,0)
  15320    ;
  15321   "RTN","VPR DJ2",92,0)
  15322    S DA=$$NE XTIFN I DA <1 S ERR=$ $ERR(4) Q
  15323   "RTN","VPR DJ2",93,0)
  15324    S UID="ur n:va:"_TYP E_":"_VPRS YS_":"_DA
  15325   "RTN","VPR DJ2",94,0)
  15326    S ^VPR(56 0.11,DA,0) =UID_U_U_T YPE
  15327   "RTN","VPR DJ2",95,0)
  15328    S ^VPR(56 0.11,"B",U ID,DA)=""
  15329   "RTN","VPR DJ2",96,0)
  15330    S ^VPR(56 0.11,"C",T YPE,DA)=""
  15331   "RTN","VPR DJ2",97,0)
  15332    Q
  15333   "RTN","VPR DJ2",98,0)
  15334    ;
  15335   "RTN","VPR DJ2",99,0)
  15336   NEW ; -- c reate new  entry in ^ VPR(560.11 ) from PAT ,TYPE,VPRS YS
  15337   "RTN","VPR DJ2",100,0 )
  15338    ;  Return  UID & DA,  or ERR
  15339   "RTN","VPR DJ2",101,0 )
  15340    S TYPE=$G (TYPE)
  15341   "RTN","VPR DJ2",102,0 )
  15342    I TYPE=""  S ERR=$$E RR(2,"null ") Q
  15343   "RTN","VPR DJ2",103,0 )
  15344    ;
  15345   "RTN","VPR DJ2",104,0 )
  15346    S DA=$$NE XTIFN I DA <1 S ERR=$ $ERR(4) Q
  15347   "RTN","VPR DJ2",105,0 )
  15348    S UID="ur n:va:"_TYP E_":"_VPRS YS_":"_DA
  15349   "RTN","VPR DJ2",106,0 )
  15350    S ^VPR(56 0.11,DA,0) =UID_U_U_T YPE
  15351   "RTN","VPR DJ2",107,0 )
  15352    S ^VPR(56 0.11,"B",U ID,DA)=""
  15353   "RTN","VPR DJ2",108,0 )
  15354    S ^VPR(56 0.11,"C",T YPE,DA)=""
  15355   "RTN","VPR DJ2",109,0 )
  15356    Q
  15357   "RTN","VPR DJ2",110,0 )
  15358    ;
  15359   "RTN","VPR DJ2",111,0 )
  15360   NEXTIFN()  ; -- Retur ns next av ailable IF N
  15361   "RTN","VPR DJ2",112,0 )
  15362    N I,HDR,T OTAL,DA
  15363   "RTN","VPR DJ2",113,0 )
  15364    L +^VPR(5 60.11,0):$ S($G(DILOC KTM)>0:DIL OCKTM,1:5)
  15365   "RTN","VPR DJ2",114,0 )
  15366    I '$T Q " ^"
  15367   "RTN","VPR DJ2",115,0 )
  15368    S HDR=$G( ^VPR(560.1 1,0)),TOTA L=+$P(HDR, U,4),I=$O( ^VPR(560.1 1,"?"),-1)
  15369   "RTN","VPR DJ2",116,0 )
  15370    F I=(I+1) :1 Q:'$D(^ VPR(560.11 ,I,0))
  15371   "RTN","VPR DJ2",117,0 )
  15372    S DA=I,$P (HDR,U,3,4 )=DA_U_(TO TAL+1) S ^ VPR(560.11 ,0)=HDR
  15373   "RTN","VPR DJ2",118,0 )
  15374    L -^VPR(5 60.11,0)
  15375   "RTN","VPR DJ2",119,0 )
  15376    Q DA
  15377   "RTN","VPR DJ2",120,0 )
  15378    ;
  15379   "RTN","VPR DJ2",121,0 )
  15380   ERR(X,VAL)  ; -- retu rn error m essage
  15381   "RTN","VPR DJ2",122,0 )
  15382    N MSG  S  MSG="Error "
  15383   "RTN","VPR DJ2",123,0 )
  15384    I X=1  S  MSG="Patie nt with df n '"_$G(VA L)_"' not  found"
  15385   "RTN","VPR DJ2",124,0 )
  15386    I X=2  S  MSG="Domai n type '"_ $G(VAL)_"'  not recog nized"
  15387   "RTN","VPR DJ2",125,0 )
  15388    I X=3  S  MSG="UID ' "_$G(VAL)_ "' not fou nd"
  15389   "RTN","VPR DJ2",126,0 )
  15390    I X=4  S  MSG="Unabl e to creat e new obje ct"
  15391   "RTN","VPR DJ2",127,0 )
  15392    I X=99 S  MSG="Unkno wn request "
  15393   "RTN","VPR DJ2",128,0 )
  15394    Q MSG
  15395   "RTN","VPR DJ2",129,0 )
  15396    ;
  15397   "RTN","VPR DJ2",130,0 )
  15398   HL7NOW() ;  -- Return  current t ime in HL7  format
  15399   "RTN","VPR DJ2",131,0 )
  15400    Q $P($$FM THL7^XLFDT ($$NOW^XLF DT),"-")
  15401   "RTN","VPR DJFS")
  15402   0^85^B5416 9565
  15403   "RTN","VPR DJFS",1,0)
  15404   VPRDJFS ;S LC/KCM --  Asynchrono us Extract s and Fres hness via  stream
  15405   "RTN","VPR DJFS",2,0)
  15406    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  15407   "RTN","VPR DJFS",3,0)
  15408    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  15409   "RTN","VPR DJFS",4,0)
  15410    ;
  15411   "RTN","VPR DJFS",5,0)
  15412    ;
  15413   "RTN","VPR DJFS",6,0)
  15414    ; PUT/POS T   call $ $TAG^ROUTI NE(.args,. body)
  15415   "RTN","VPR DJFS",7,0)
  15416    ; GET/DEL ETE call    TAG^ROUTI NE(.respon se,.args)
  15417   "RTN","VPR DJFS",8,0)
  15418    ;
  15419   "RTN","VPR DJFS",9,0)
  15420    ; TODO: c hange this  to use ^V PR(560) in stead of ^ XTMP("VPRF P")
  15421   "RTN","VPR DJFS",10,0 )
  15422    ; TODO: c reate func tion to bu ild ARGS f rom PATH
  15423   "RTN","VPR DJFS",11,0 )
  15424    ; TODO: c reate func tion to re turn TAG^R OUTINE fro m MTHD,PAT H
  15425   "RTN","VPR DJFS",12,0 )
  15426    ;
  15427   "RTN","VPR DJFS",13,0 )
  15428    ; todo: g et the big  sync work ing
  15429   "RTN","VPR DJFS",14,0 )
  15430    ; todo: c hange to u se RPC cal ls
  15431   "RTN","VPR DJFS",15,0 )
  15432    ; todo: a dd in fres hness 
  15433   "RTN","VPR DJFS",16,0 )
  15434    ;
  15435   "RTN","VPR DJFS",17,0 )
  15436   API(VPRFRS P,ARGS) ;
  15437   "RTN","VPR DJFS",18,0 )
  15438    N VPRFERR ,VPRFHMP,C NT,ACNT
  15439   "RTN","VPR DJFS",19,0 )
  15440    K ^TMP("V PRF",$J)
  15441   "RTN","VPR DJFS",20,0 )
  15442    S VPRFRSP =$NA(^TMP( "VPRF",$J) )
  15443   "RTN","VPR DJFS",21,0 )
  15444    S VPRSYS= $$GET^XPAR ("SYS","VP R SYSTEM N AME")
  15445   "RTN","VPR DJFS",22,0 )
  15446    S VPRFHMP =$TR($G(AR GS("server ")),"~","= ")
  15447   "RTN","VPR DJFS",23,0 )
  15448    I ARGS("c ommand")=" putPtSubsc ription" D   Q
  15449   "RTN","VPR DJFS",24,0 )
  15450    . N LOC
  15451   "RTN","VPR DJFS",25,0 )
  15452    . S LOC=$ $PUTSUB^VP RDJFSP(.AR GS)
  15453   "RTN","VPR DJFS",26,0 )
  15454    . I $L(LO C) S ^TMP( "VPRF",$J, 1)="{""api Version"": ""1.0"","" location"" :"""_LOC_" """_$$PROG RESS_"}"
  15455   "RTN","VPR DJFS",27,0 )
  15456    I ARGS("c ommand")=" startOpera tionalData Extract" D   Q
  15457   "RTN","VPR DJFS",28,0 )
  15458    . N LOC
  15459   "RTN","VPR DJFS",29,0 )
  15460    . S ARGS( "localId") ="OPD"  ;  use OPD to  indicate  "sync oper ational"
  15461   "RTN","VPR DJFS",30,0 )
  15462    . S LOC=$ $PUTSUB^VP RDJFSP(.AR GS)
  15463   "RTN","VPR DJFS",31,0 )
  15464    . I $L(LO C) S ^TMP( "VPRF",$J, 1)="{""api Version"": ""1.0"","" location"" :"""_LOC_" ""}"
  15465   "RTN","VPR DJFS",32,0 )
  15466    I ARGS("c ommand")=" getPtUpdat es" D  Q
  15467   "RTN","VPR DJFS",33,0 )
  15468    . D GETSU B^VPRDJFSG (VPRFRSP,. ARGS)
  15469   "RTN","VPR DJFS",34,0 )
  15470    I ARGS("c ommand")=" resetAllSu bscription s" D  Q
  15471   "RTN","VPR DJFS",35,0 )
  15472    . D RESET SVR(.ARGS)
  15473   "RTN","VPR DJFS",36,0 )
  15474    . S ^TMP( "VPRF",$J, 1)="{""api Version"": ""1.0"","" removed"": ""true""}"
  15475   "RTN","VPR DJFS",37,0 )
  15476    ;
  15477   "RTN","VPR DJFS",38,0 )
  15478    D SETERR( "command n ot recogni zed")  ; s hould not  get this f ar
  15479   "RTN","VPR DJFS",39,0 )
  15480    Q
  15481   "RTN","VPR DJFS",40,0 )
  15482    ;
  15483   "RTN","VPR DJFS",41,0 )
  15484    ; --- del ete a pati ent subscr iption
  15485   "RTN","VPR DJFS",42,0 )
  15486    ;
  15487   "RTN","VPR DJFS",43,0 )
  15488   DELSUB(RSP ,ARGS) ; c ancel a su bscription
  15489   "RTN","VPR DJFS",44,0 )
  15490    ; DELETE  with: /vpr /subscript ion/{hmpSr vId}/patie nt/{pid}
  15491   "RTN","VPR DJFS",45,0 )
  15492    ; remove  patient fr om VPR SUB SCRIPTION  file
  15493   "RTN","VPR DJFS",46,0 )
  15494    ; remove  ^XTMP(VPRX  and ^XTMP (VPRH node s
  15495   "RTN","VPR DJFS",47,0 )
  15496    ; look ah ead (from  lastId) an d remove a ny nodes f or the pat ient
  15497   "RTN","VPR DJFS",48,0 )
  15498    N DFN,HMP SRV,BATCH, HMPSRVID
  15499   "RTN","VPR DJFS",49,0 )
  15500    S DFN=$$D FN(ARGS("p id")) Q:$D (VPRFERR)
  15501   "RTN","VPR DJFS",50,0 )
  15502    S HMPSRV= ARGS("hmpS rvId")
  15503   "RTN","VPR DJFS",51,0 )
  15504    S BATCH=" VPRFX~"_HM PSRV_"~"_D FN
  15505   "RTN","VPR DJFS",52,0 )
  15506    L +^XTMP( "VPRFP",DF N,HMPSRV): 20 E  D SE TERR("unab le to get  lock") Q
  15507   "RTN","VPR DJFS",53,0 )
  15508    ; if extr act still  running, i t should r emove itse lf when it  finishes
  15509   "RTN","VPR DJFS",54,0 )
  15510    K ^XTMP(" VPRFX~"_HM PSRV_"~"_D FN) ; kill  extract n odes
  15511   "RTN","VPR DJFS",55,0 )
  15512    K ^XTMP(" VPRFH~"_HM PSRV_"~"_D FN) ; kill  held fres hness upda tes
  15513   "RTN","VPR DJFS",56,0 )
  15514    ; remove  all nodes  for this p atient bet ween "last " and "nex t"
  15515   "RTN","VPR DJFS",57,0 )
  15516    ; loop fo rward from  "last" in  ^XTMP("VP RFP",0,hmp Srv) and r emove node s for this  DFN
  15517   "RTN","VPR DJFS",58,0 )
  15518    K ^XTMP(" VPRFP",DFN ,HMPSRV)       ; kill  subscript ion
  15519   "RTN","VPR DJFS",59,0 )
  15520    D DELPT(D FN,HMPSRV)
  15521   "RTN","VPR DJFS",60,0 )
  15522    ;K ^VPR(5 60,$O(^VPR (560,"B",H MPSRV,"")) ,1,DFN),^V PR(560,"AI TEM",DFN,H MPSRV)
  15523   "RTN","VPR DJFS",61,0 )
  15524    L -^XTMP( "VPRFP",DF N,HMPSRV)
  15525   "RTN","VPR DJFS",62,0 )
  15526    S RSP="{" "apiVersio n"":""1.0" ",""succes s"":""true ""}" ; if  successful
  15527   "RTN","VPR DJFS",63,0 )
  15528    Q
  15529   "RTN","VPR DJFS",64,0 )
  15530   DELPT(DFN, SRV) ; del ete patien t DFN for  server SRV
  15531   "RTN","VPR DJFS",65,0 )
  15532    N DIK,DA
  15533   "RTN","VPR DJFS",66,0 )
  15534    S DA(1)=$ O(^VPR(560 ,"B",SRV," ")) Q:'DA( 1)
  15535   "RTN","VPR DJFS",67,0 )
  15536    S DA=DFN  Q:'DA
  15537   "RTN","VPR DJFS",68,0 )
  15538    S DIK="^V PR(560,"_D A(1)_",1,"
  15539   "RTN","VPR DJFS",69,0 )
  15540    D ^DIK
  15541   "RTN","VPR DJFS",70,0 )
  15542    Q
  15543   "RTN","VPR DJFS",71,0 )
  15544    ;
  15545   "RTN","VPR DJFS",72,0 )
  15546    ; --- pos t freshnes s updates  (internal  to VistA)
  15547   "RTN","VPR DJFS",73,0 )
  15548    ;
  15549   "RTN","VPR DJFS",74,0 )
  15550   POST(DFN,T YPE,ID,ACT ,SERVER,NO DES) ; add s new fres hness item , return D T-seq
  15551   "RTN","VPR DJFS",75,0 )
  15552    ; if init ializing u se: ^XTMP( "VPRFH-hmp serverid-d fn",seq#)     -hold
  15553   "RTN","VPR DJFS",76,0 )
  15554    ;       o therwise u se: ^XTMP( "VPRFS-hmp serverid-d ate",seq#)    -stream
  15555   "RTN","VPR DJFS",77,0 )
  15556    ;
  15557   "RTN","VPR DJFS",78,0 )
  15558    ; loop th rough subs cribing st reams for  this patie nt
  15559   "RTN","VPR DJFS",79,0 )
  15560    ; if pati ent is ini tialized f or an hmp  server sen d events d irectly to  stream
  15561   "RTN","VPR DJFS",80,0 )
  15562    ; otherwi se, events  go to tem porary hol ding area
  15563   "RTN","VPR DJFS",81,0 )
  15564    ; initial  extracts  always sen t directly  to stream
  15565   "RTN","VPR DJFS",82,0 )
  15566    N HMPSRV, INIT,STREA M,DATE,SEQ ,CNT
  15567   "RTN","VPR DJFS",83,0 )
  15568    S DATE=$$ DT^XLFDT
  15569   "RTN","VPR DJFS",84,0 )
  15570    S HMPSRV= "" F  S HM PSRV=$O(^V PR(560,"AI TEM",DFN,H MPSRV)) Q: '$L(HMPSRV )  D
  15571   "RTN","VPR DJFS",85,0 )
  15572    .I SERVER '="",HMPSR V'=SERVER  Q
  15573   "RTN","VPR DJFS",86,0 )
  15574    . I '$D(^ VPR(560,"A ITEM",DFN, HMPSRV)) Q            ; patient  not subscr ibed
  15575   "RTN","VPR DJFS",87,0 )
  15576    . S INIT= (^VPR(560, "AITEM",DF N,HMPSRV)= 2),CNT=1   ; 2 means  patient in itialized
  15577   "RTN","VPR DJFS",88,0 )
  15578    . I $E(TY PE,1,4)="s ync" S INI T=1                   ; sync* go es to main  stream
  15579   "RTN","VPR DJFS",89,0 )
  15580    . I TYPE= "syncDomai n" S CNT=+ $P(ID,":", 3) S:CNT<1  CNT=1 ; C NT must be  >0
  15581   "RTN","VPR DJFS",90,0 )
  15582    . S STREA M=$S(INIT: "VPRFS~",1 :"VPRFH~") _HMPSRV_"~ "_$S(INIT: DATE,1:DFN )
  15583   "RTN","VPR DJFS",91,0 )
  15584    . I '$D(^ XTMP(STREA M)) D NEWX TMP(STREAM ,2,"VPR Fr eshness St ream")
  15585   "RTN","VPR DJFS",92,0 )
  15586    . L +^XTM P(STREAM): 5 E  S $EC =",Uno loc k obtained ," Q  ; th row error
  15587   "RTN","VPR DJFS",93,0 )
  15588    . S SEQ=$ G(^XTMP(ST REAM,"last "),0)+CNT
  15589   "RTN","VPR DJFS",94,0 )
  15590    . S ^XTMP (STREAM,SE Q)=DFN_U_T YPE_U_ID_U _$G(ACT)_U _$P($H,"," ,2)
  15591   "RTN","VPR DJFS",95,0 )
  15592    . S ^XTMP (STREAM,"l ast")=SEQ
  15593   "RTN","VPR DJFS",96,0 )
  15594    . L -^XTM P(STREAM)
  15595   "RTN","VPR DJFS",97,0 )
  15596    . ; NODES (hmpserver id)=stream Date^seque nce -- opt ionally re turned
  15597   "RTN","VPR DJFS",98,0 )
  15598    . S NODES ($P(STREAM ,"~",2))=$ S(INIT:DAT E,1:0)_U_S EQ
  15599   "RTN","VPR DJFS",99,0 )
  15600    Q
  15601   "RTN","VPR DJFS",100, 0)
  15602    ;
  15603   "RTN","VPR DJFS",101, 0)
  15604   NEWXTMP(NO DE,DAYS,DE SC) ; Set  a new node  in ^XTMP
  15605   "RTN","VPR DJFS",102, 0)
  15606    K ^XTMP(N ODE)
  15607   "RTN","VPR DJFS",103, 0)
  15608    S ^XTMP(N ODE,0)=$$H TFM^XLFDT( +$H+DAYS)_ U_$$HTFM^X LFDT(+$H)_ U_DESC
  15609   "RTN","VPR DJFS",104, 0)
  15610    Q
  15611   "RTN","VPR DJFS",105, 0)
  15612   PIDS(DFN)  ; return s tring cont aining pat ient id's  ready for  JSON
  15613   "RTN","VPR DJFS",106, 0)
  15614    ; expects  VPRFSYS,  VPRFHMP
  15615   "RTN","VPR DJFS",107, 0)
  15616    Q:'DFN ""
  15617   "RTN","VPR DJFS",108, 0)
  15618    ;
  15619   "RTN","VPR DJFS",109, 0)
  15620    N X
  15621   "RTN","VPR DJFS",110, 0)
  15622    S X=",""p id"":"""_$ $PID(DFN)_ """"
  15623   "RTN","VPR DJFS",111, 0)
  15624    S X=X_"," "systemId" ":"""_VPRS YS_""""
  15625   "RTN","VPR DJFS",112, 0)
  15626    S X=X_"," "localId"" :"""_DFN_" """
  15627   "RTN","VPR DJFS",113, 0)
  15628    S X=X_"," "icn"":""" _+$$GETICN ^MPIF001(D FN)_""""
  15629   "RTN","VPR DJFS",114, 0)
  15630    Q X
  15631   "RTN","VPR DJFS",115, 0)
  15632    ;
  15633   "RTN","VPR DJFS",116, 0)
  15634   PID(DFN) ;  return mo st likely  PID (ICN o r SYS;DFN)
  15635   "RTN","VPR DJFS",117, 0)
  15636    Q:'DFN ""
  15637   "RTN","VPR DJFS",118, 0)
  15638    I '$D(VPR SYS) S VPR SYS=$$GET^ XPAR("SYS" ,"VPR SYST EM NAME")
  15639   "RTN","VPR DJFS",119, 0)
  15640    Q VPRSYS_ ";"_DFN             ;  otherwise  use SysId ;DFN
  15641   "RTN","VPR DJFS",120, 0)
  15642    ;
  15643   "RTN","VPR DJFS",121, 0)
  15644   DFN(PID) ;  return th e DFN give n the PID  (ICN or SY S;DFN)
  15645   "RTN","VPR DJFS",122, 0)
  15646    N DFN
  15647   "RTN","VPR DJFS",123, 0)
  15648    S PID=$TR (PID,":"," ;")
  15649   "RTN","VPR DJFS",124, 0)
  15650    I PID'["; " D  Q DFN   ; treat  as ICN
  15651   "RTN","VPR DJFS",125, 0)
  15652    . S DFN=$ $GETDFN^MP IF001(PID)
  15653   "RTN","VPR DJFS",126, 0)
  15654    . I DFN<0  D SETERR( $P(DFN,"^" ,2))
  15655   "RTN","VPR DJFS",127, 0)
  15656    ; otherwi se
  15657   "RTN","VPR DJFS",128, 0)
  15658    I $P(PID, ";")'=$$GE T^XPAR("SY S","VPR SY STEM NAME" ) D SETERR ("DFN unkn own to thi s system")  Q 0
  15659   "RTN","VPR DJFS",129, 0)
  15660    Q $P(PID, ";",2)
  15661   "RTN","VPR DJFS",130, 0)
  15662    ;
  15663   "RTN","VPR DJFS",131, 0)
  15664   PROGRESS(L ASTITM) ;  set the no de in REF  with progr ess proper ties
  15665   "RTN","VPR DJFS",132, 0)
  15666    ; expects  VPRFHMP,V PRSYS
  15667   "RTN","VPR DJFS",133, 0)
  15668    N RSLT,HM PIEN,CNT,S TS,TS,DFN, FIRST
  15669   "RTN","VPR DJFS",134, 0)
  15670    S HMPIEN= $O(^VPR(56 0,"B",VPRF HMP,0)) Q: 'HMPIEN
  15671   "RTN","VPR DJFS",135, 0)
  15672    S CNT=0,R SLT=""
  15673   "RTN","VPR DJFS",136, 0)
  15674    F STS=0,1  D  ; 0=un initialize d, 1=initi alizing
  15675   "RTN","VPR DJFS",137, 0)
  15676    . S FIRST =1
  15677   "RTN","VPR DJFS",138, 0)
  15678    . S RSLT= $S(STS=0:" ,""waiting Pids"":[", 1:RSLT_"], ""processi ngPids"":[ ")
  15679   "RTN","VPR DJFS",139, 0)
  15680    . S TS=0  F  S TS=$O (^VPR(560, HMPIEN,1," AP",STS,TS )) Q:'TS   D  Q:CNT>9 9
  15681   "RTN","VPR DJFS",140, 0)
  15682    . . S DFN =0 F  S DF N=$O(^VPR( 560,HMPIEN ,1,"AP",ST S,TS,DFN))  Q:'DFN  D
  15683   "RTN","VPR DJFS",141, 0)
  15684    . . . S C NT=CNT+1
  15685   "RTN","VPR DJFS",142, 0)
  15686    . . . S R SLT=RSLT_$ S(FIRST=1: "",1:",")_ """"_VPRSY S_";"_DFN_ """"
  15687   "RTN","VPR DJFS",143, 0)
  15688    . . . S F IRST=0
  15689   "RTN","VPR DJFS",144, 0)
  15690    S RSLT=RS LT_"]"
  15691   "RTN","VPR DJFS",145, 0)
  15692    ;
  15693   "RTN","VPR DJFS",146, 0)
  15694    N STRM,ST RMDT,CURRD T
  15695   "RTN","VPR DJFS",147, 0)
  15696    I $G(LAST ITM)="" S  LASTITM=$P (^VPR(560, HMPIEN,0), U,2)
  15697   "RTN","VPR DJFS",148, 0)
  15698    I $L(LAST ITM,"-")<2  S LASTITM =$$DT^XLFD T_"-"_+LAS TITM
  15699   "RTN","VPR DJFS",149, 0)
  15700    S STRMDT= $P(LASTITM ,"-"),CURR DT=$$DT^XL FDT,SEQ=$P (LASTITM," -",2)
  15701   "RTN","VPR DJFS",150, 0)
  15702    S CNT=0 F   D  Q:$$F MDIFF^XLFD T(STRMDT,C URRDT,1)'< 0
  15703   "RTN","VPR DJFS",151, 0)
  15704    . S STRM= "VPRFS~"_V PRFHMP_"~" _STRMDT
  15705   "RTN","VPR DJFS",152, 0)
  15706    . S CNT=C NT+$G(^XTM P(STRM,"la st"))-SEQ
  15707   "RTN","VPR DJFS",153, 0)
  15708    . S STRMD T=$$FMADD^ XLFDT(STRM DT,1),SEQ= 0
  15709   "RTN","VPR DJFS",154, 0)
  15710    S RSLT=RS LT_",""rem ainingObje cts"":"_CN T
  15711   "RTN","VPR DJFS",155, 0)
  15712    Q RSLT
  15713   "RTN","VPR DJFS",156, 0)
  15714    ;
  15715   "RTN","VPR DJFS",157, 0)
  15716    ; --- han dle errors
  15717   "RTN","VPR DJFS",158, 0)
  15718    ;
  15719   "RTN","VPR DJFS",159, 0)
  15720   SETERR(MSG ) ; create  error obj ect in ^TM P("VPRFERR ",$J) and  set VPRFER R
  15721   "RTN","VPR DJFS",160, 0)
  15722    ; TODO: e scape MSG  for JSON
  15723   "RTN","VPR DJFS",161, 0)
  15724    S @VPRFRS P@(1)="{"" apiVersion "":""1.0"" ,""error"" :{""messag e"":"""_MS G_"""}}"
  15725   "RTN","VPR DJFS",162, 0)
  15726    S ^TMP("V PRFERR",$J ,$H)=MSG
  15727   "RTN","VPR DJFS",163, 0)
  15728    S VPRFERR =1
  15729   "RTN","VPR DJFS",164, 0)
  15730    Q
  15731   "RTN","VPR DJFS",165, 0)
  15732    ;
  15733   "RTN","VPR DJFS",166, 0)
  15734   DEBUG(MSG)  ;
  15735   "RTN","VPR DJFS",167, 0)
  15736    S ^TMP("V PRDEBUG",$ J,0)=$G(^T MP("VPRDEB UG",$J,0), 0)+1
  15737   "RTN","VPR DJFS",168, 0)
  15738    I $D(MSG) '=1 M ^TMP ("VPRDEBUG ",$J,^TMP( "VPRDEBUG" ,$J,0))=MS G
  15739   "RTN","VPR DJFS",169, 0)
  15740    E  S ^TMP ("VPRDEBUG ",$J,^TMP( "VPRDEBUG" ,$J,0))=MS G
  15741   "RTN","VPR DJFS",170, 0)
  15742    Q
  15743   "RTN","VPR DJFS",171, 0)
  15744   RESETSVR(A RGS) ;
  15745   "RTN","VPR DJFS",172, 0)
  15746    N DA,DIE, DIK,DR,IEN ,SRV,SRVIE N,X
  15747   "RTN","VPR DJFS",173, 0)
  15748    S SRV=$G( ARGS("serv er")) I SR V="" Q
  15749   "RTN","VPR DJFS",174, 0)
  15750    S DA=$O(^ VPR(560,"B ",SRV,""))  I DA'>0 Q
  15751   "RTN","VPR DJFS",175, 0)
  15752    S SRVIEN= DA
  15753   "RTN","VPR DJFS",176, 0)
  15754    L +^VPR(5 60,SRVIEN) :5 E  S $E C=",Uno lo ck obtaine d," Q
  15755   "RTN","VPR DJFS",177, 0)
  15756    ;delete o perational  data fiel d
  15757   "RTN","VPR DJFS",178, 0)
  15758    S DIE="^V PR(560,",D R=".03///@ " D ^DIE
  15759   "RTN","VPR DJFS",179, 0)
  15760    S DA(1)=D A,DA=0
  15761   "RTN","VPR DJFS",180, 0)
  15762    ;delate p atient mul tiple valu es
  15763   "RTN","VPR DJFS",181, 0)
  15764    S DIK="^V PR(560,"_D A(1)_",1,"
  15765   "RTN","VPR DJFS",182, 0)
  15766    F  S DA=$ O(^VPR(560 ,DA(1),1,D A)) Q:DA'> 0  D ^DIK
  15767   "RTN","VPR DJFS",183, 0)
  15768    ;kill ser ver ^XTMP
  15769   "RTN","VPR DJFS",184, 0)
  15770    S X="VPRF " F  S X=$ O(^XTMP(X) ) Q:$E(X,1 ,4)'="VPRF "  D
  15771   "RTN","VPR DJFS",185, 0)
  15772    . I X[SRV  K ^XTMP(X ) I 1
  15773   "RTN","VPR DJFS",186, 0)
  15774    ;kill tid y node
  15775   "RTN","VPR DJFS",187, 0)
  15776    K ^XTMP(" VPRFP","ti dy",SRV)
  15777   "RTN","VPR DJFS",188, 0)
  15778    L -^VPR(5 60,SRVIEN)
  15779   "RTN","VPR DJFS",189, 0)
  15780    Q
  15781   "RTN","VPR DJFS",190, 0)
  15782    ;
  15783   "RTN","VPR DJFS",191, 0)
  15784   CLEARDOM(S VR,PAT) ;
  15785   "RTN","VPR DJFS",192, 0)
  15786    Q
  15787   "RTN","VPR DJFS",193, 0)
  15788    ;
  15789   "RTN","VPR DJFS",194, 0)
  15790   CLEARPAT(S VR,PAT) ;
  15791   "RTN","VPR DJFS",195, 0)
  15792    I '$D(^XT MP("VPRFP" ,PAT,SVR))  Q
  15793   "RTN","VPR DJFS",196, 0)
  15794    ;do we ne ed a check  for patie nt initial ized?
  15795   "RTN","VPR DJFS",197, 0)
  15796    K ^XTMP(" VPRFP",PAT ,SVR)
  15797   "RTN","VPR DJFS",198, 0)
  15798    Q
  15799   "RTN","VPR DJFS",199, 0)
  15800    ;
  15801   "RTN","VPR DJFS",200, 0)
  15802   VPRSET(DA, NEW) ;
  15803   "RTN","VPR DJFS",201, 0)
  15804    N IEN,NAM E
  15805   "RTN","VPR DJFS",202, 0)
  15806    S IEN=0 F   S IEN=$O (^VPR(560, IEN)) Q:IE N'>0  D
  15807   "RTN","VPR DJFS",203, 0)
  15808    .S NAME=$ P(^VPR(560 ,IEN,0),U)
  15809   "RTN","VPR DJFS",204, 0)
  15810    .I $D(^VP R(560,IEN, 1,NEW(1))) >0 S ^VPR( 560,"AITEM ",NEW(1),N AME)=NEW(2 )
  15811   "RTN","VPR DJFS",205, 0)
  15812    Q
  15813   "RTN","VPR DJFS",206, 0)
  15814    ;
  15815   "RTN","VPR DJFS",207, 0)
  15816   VPRKILL(DA ,OLD) ;
  15817   "RTN","VPR DJFS",208, 0)
  15818    N NAME
  15819   "RTN","VPR DJFS",209, 0)
  15820    S NAME=$P ($G(^VPR(5 60,DA(1),0 )),U) I NA ME="" Q
  15821   "RTN","VPR DJFS",210, 0)
  15822    K ^VPR(56 0,"AITEM", OLD(1),NAM E)
  15823   "RTN","VPR DJFS",211, 0)
  15824    Q
  15825   "RTN","VPR DJFS",212, 0)
  15826    ;
  15827   "RTN","VPR DJFS",213, 0)
  15828   VPROSET(DA ,NEW) ;
  15829   "RTN","VPR DJFS",214, 0)
  15830    N IEN,NAM E
  15831   "RTN","VPR DJFS",215, 0)
  15832    S IEN=0 F   S IEN=$O (^VPR(560, IEN)) Q:IE N'>0  D
  15833   "RTN","VPR DJFS",216, 0)
  15834    .S NAME=$ P(^VPR(560 ,IEN,0),U)
  15835   "RTN","VPR DJFS",217, 0)
  15836    .S ^VPR(5 60,"AITEM" ,"OPD",NAM E)=NEW
  15837   "RTN","VPR DJFS",218, 0)
  15838    Q
  15839   "RTN","VPR DJFS",219, 0)
  15840    ;
  15841   "RTN","VPR DJFS",220, 0)
  15842   VPROKILL(D A) ;
  15843   "RTN","VPR DJFS",221, 0)
  15844    N NAME
  15845   "RTN","VPR DJFS",222, 0)
  15846    S NAME=$P ($G(^VPR(5 60,DA,0)), U) I NAME= "" Q
  15847   "RTN","VPR DJFS",223, 0)
  15848    K ^VPR(56 0,"AITEM", "OPD",NAME )
  15849   "RTN","VPR DJFS",224, 0)
  15850    Q
  15851   "RTN","VPR DJFS",225, 0)
  15852   KILL ; cle ar out all  ^XTMP nod es
  15853   "RTN","VPR DJFS",226, 0)
  15854    N X
  15855   "RTN","VPR DJFS",227, 0)
  15856    S X="VPRF " F  S X=$ O(^XTMP(X) ) Q:$E(X,1 ,4)'="VPRF "  W !,X   K ^XTMP(X)
  15857   "RTN","VPR DJFS",228, 0)
  15858    Q
  15859   "RTN","VPR DJFS",229, 0)
  15860   KILLSVR(SV R) ; clear  out for s pecific ma shine
  15861   "RTN","VPR DJFS",230, 0)
  15862    N X
  15863   "RTN","VPR DJFS",231, 0)
  15864    S X="VPRF " F  S X=$ O(^XTMP(X) ) Q:$E(X,1 ,4)'="VPRF "  D
  15865   "RTN","VPR DJFS",232, 0)
  15866    . I X[SVR  W !,X  K  ^XTMP(X) I  1
  15867   "RTN","VPR DJFS",233, 0)
  15868    S X="" F   S X=$O(^X TMP("VPRFP ",X)) Q:X= ""  D
  15869   "RTN","VPR DJFS",234, 0)
  15870    . I $D(^X TMP("VPRFP ",X,SVR))  K ^XTMP("V PRFP",X,SV R)
  15871   "RTN","VPR DJFS",235, 0)
  15872    Q
  15873   "RTN","VPR DJFSD")
  15874   0^101^B480 2393
  15875   "RTN","VPR DJFSD",1,0 )
  15876   VPRDJFSD ; SLC/KCM --  Domain Li sts for Ex tract and  Freshness  Stream
  15877   "RTN","VPR DJFSD",2,0 )
  15878    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  15879   "RTN","VPR DJFSD",3,0 )
  15880    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  15881   "RTN","VPR DJFSD",4,0 )
  15882    ;
  15883   "RTN","VPR DJFSD",5,0 )
  15884   PTDOMS(LIS T) ; load  default pa tient doma ins (put i n paramete r?)
  15885   "RTN","VPR DJFSD",6,0 )
  15886    ;;allergy
  15887   "RTN","VPR DJFSD",7,0 )
  15888    ;;auxilia ry
  15889   "RTN","VPR DJFSD",8,0 )
  15890    ;;appoint ment
  15891   "RTN","VPR DJFSD",9,0 )
  15892    ;;diagnos is
  15893   "RTN","VPR DJFSD",10, 0)
  15894    ;;documen t
  15895   "RTN","VPR DJFSD",11, 0)
  15896    ;;factor
  15897   "RTN","VPR DJFSD",12, 0)
  15898    ;;immuniz ation
  15899   "RTN","VPR DJFSD",13, 0)
  15900    ;;lab
  15901   "RTN","VPR DJFSD",14, 0)
  15902    ;;med
  15903   "RTN","VPR DJFSD",15, 0)
  15904    ;;obs
  15905   "RTN","VPR DJFSD",16, 0)
  15906    ;;order
  15907   "RTN","VPR DJFSD",17, 0)
  15908    ;;problem
  15909   "RTN","VPR DJFSD",18, 0)
  15910    ;;procedu re
  15911   "RTN","VPR DJFSD",19, 0)
  15912    ;;consult
  15913   "RTN","VPR DJFSD",20, 0)
  15914    ;;image
  15915   "RTN","VPR DJFSD",21, 0)
  15916    ;;surgery
  15917   "RTN","VPR DJFSD",22, 0)
  15918    ;;task
  15919   "RTN","VPR DJFSD",23, 0)
  15920    ;;visit
  15921   "RTN","VPR DJFSD",24, 0)
  15922    ;;vital
  15923   "RTN","VPR DJFSD",25, 0)
  15924    ;;mh
  15925   "RTN","VPR DJFSD",26, 0)
  15926    ;;ptf
  15927   "RTN","VPR DJFSD",27, 0)
  15928    ;;exam
  15929   "RTN","VPR DJFSD",28, 0)
  15930    ;;cpt
  15931   "RTN","VPR DJFSD",29, 0)
  15932    ;;educati on
  15933   "RTN","VPR DJFSD",30, 0)
  15934    ;;pov
  15935   "RTN","VPR DJFSD",31, 0)
  15936    ;;skin
  15937   "RTN","VPR DJFSD",32, 0)
  15938    ;;treatme nt
  15939   "RTN","VPR DJFSD",33, 0)
  15940    ;;roadtri p
  15941   "RTN","VPR DJFSD",34, 0)
  15942    ;;zzzzz
  15943   "RTN","VPR DJFSD",35, 0)
  15944    ;
  15945   "RTN","VPR DJFSD",36, 0)
  15946    N I,X
  15947   "RTN","VPR DJFSD",37, 0)
  15948    F I=1:1 S  X=$P($T(P TDOMS+I)," ;;",2,99)  Q:X="zzzzz "  S LIST( I)=X
  15949   "RTN","VPR DJFSD",38, 0)
  15950    Q
  15951   "RTN","VPR DJFSD",39, 0)
  15952    ;
  15953   "RTN","VPR DJFSD",40, 0)
  15954   OPDOMS(LIS T) ; load  default op erational  domains (p ut in para meter?)
  15955   "RTN","VPR DJFSD",41, 0)
  15956    ;;asu-cla ss;^USR(89 30)
  15957   "RTN","VPR DJFSD",42, 0)
  15958    ;;asu-rul e;^USR(893 0.1)
  15959   "RTN","VPR DJFSD",43, 0)
  15960    ;;categor y;^VPR(560 .11)
  15961   "RTN","VPR DJFSD",44, 0)
  15962    ;;chartta b;^VPR(560 .11)
  15963   "RTN","VPR DJFSD",45, 0)
  15964    ;;display group;^ORD (100.98)
  15965   "RTN","VPR DJFSD",46, 0)
  15966    ;;doc-def ;^TIU(8925 .1)
  15967   "RTN","VPR DJFSD",47, 0)
  15968    ;;labgrou p;^LAB(64. 5,1,1)
  15969   "RTN","VPR DJFSD",48, 0)
  15970    ;;labpane l;^LAB(60)
  15971   "RTN","VPR DJFSD",49, 0)
  15972    ;;locatio n;^SC
  15973   "RTN","VPR DJFSD",50, 0)
  15974    ;;orderab le;^ORD(10 1.43)
  15975   "RTN","VPR DJFSD",51, 0)
  15976    ;;page;^V PR(560.11)
  15977   "RTN","VPR DJFSD",52, 0)
  15978    ;;pt-sele ct;^DPT
  15979   "RTN","VPR DJFSD",53, 0)
  15980    ;;personp hoto;^VPR( 560.11)
  15981   "RTN","VPR DJFSD",54, 0)
  15982    ;;pointof care;^VPR( 560.11)
  15983   "RTN","VPR DJFSD",55, 0)
  15984    ;;quick;^ ORD(101.41 )
  15985   "RTN","VPR DJFSD",56, 0)
  15986    ;;roster; ^VPROSTER
  15987   "RTN","VPR DJFSD",57, 0)
  15988    ;;route;^ PS(51.2)
  15989   "RTN","VPR DJFSD",58, 0)
  15990    ;;schedul e;^PS(51.1 )
  15991   "RTN","VPR DJFSD",59, 0)
  15992    ;;team;^V PR(560.11)
  15993   "RTN","VPR DJFSD",60, 0)
  15994    ;;teampos ition;^VPR (560.11)
  15995   "RTN","VPR DJFSD",61, 0)
  15996    ;;user;^V A(200)
  15997   "RTN","VPR DJFSD",62, 0)
  15998    ;;usertab prefs;^VPR (560.11)
  15999   "RTN","VPR DJFSD",63, 0)
  16000    ;;viewdef def;^VPR(5 60.11)
  16001   "RTN","VPR DJFSD",64, 0)
  16002    ;;viewdef defcoldefc onfigtempl ate;^VPR(5 60.11)
  16003   "RTN","VPR DJFSD",65, 0)
  16004    ;;zzzzz
  16005   "RTN","VPR DJFSD",66, 0)
  16006    ;;
  16007   "RTN","VPR DJFSD",67, 0)
  16008    ;;clioter minology
  16009   "RTN","VPR DJFSD",68, 0)
  16010    ;;doc-act ion
  16011   "RTN","VPR DJFSD",69, 0)
  16012    ;;doc-sta tus
  16013   "RTN","VPR DJFSD",70, 0)
  16014    ;
  16015   "RTN","VPR DJFSD",71, 0)
  16016    N I,X
  16017   "RTN","VPR DJFSD",72, 0)
  16018    F I=1:1 S  X=$P($T(O PDOMS+I)," ;",3) Q:X= "zzzzz"  S  LIST(I)=X
  16019   "RTN","VPR DJFSD",73, 0)
  16020    Q
  16021   "RTN","VPR DJFSD",74, 0)
  16022    ;
  16023   "RTN","VPR DJFSG")
  16024   0^86^B9704 9334
  16025   "RTN","VPR DJFSG",1,0 )
  16026   VPRDJFSG ; SLC/KCM --  GET for E xtract and  Freshness  Stream
  16027   "RTN","VPR DJFSG",2,0 )
  16028    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  16029   "RTN","VPR DJFSG",3,0 )
  16030    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  16031   "RTN","VPR DJFSG",4,0 )
  16032    ;
  16033   "RTN","VPR DJFSG",5,0 )
  16034    ;
  16035   "RTN","VPR DJFSG",6,0 )
  16036    ; --- ret rieve upda tes for an  HMP serve r's subscr iptions
  16037   "RTN","VPR DJFSG",7,0 )
  16038    ;
  16039   "RTN","VPR DJFSG",8,0 )
  16040   GETSUB(VPR FRSP,ARGS)  ; retriev e items fr om stream
  16041   "RTN","VPR DJFSG",9,0 )
  16042    ;      GE T from: /v pr/subscri ption/{hmp SrvId}/{la st}?limit= {limit}
  16043   "RTN","VPR DJFSG",10, 0)
  16044    ; ARGS("l ast") : da te-seq of  last item  retrieved  (ex. 31312 06-27)
  16045   "RTN","VPR DJFSG",11, 0)
  16046    ; ARGS("l imit"): ma ximum numb er of item s to retur n (default  99999)
  16047   "RTN","VPR DJFSG",12, 0)
  16048    ;
  16049   "RTN","VPR DJFSG",13, 0)
  16050    ; VPRFSYS  : the id  (hash) of  the VistA  system
  16051   "RTN","VPR DJFSG",14, 0)
  16052    ; VPRFHMP  : the nam e of the H MP server 
  16053   "RTN","VPR DJFSG",15, 0)
  16054    ; VPRFSEQ  : final s equence (b ecomes nex t LASTSEQ)
  16055   "RTN","VPR DJFSG",16, 0)
  16056    ; VPRFIDX  : index t o iterate  from LASTS EQ to fina l sequence
  16057   "RTN","VPR DJFSG",17, 0)
  16058    ; VPRFLAS T: used to  clean up  extracts p rior to th is
  16059   "RTN","VPR DJFSG",18, 0)
  16060    ; VPRFSTR M: the ext ract/fresh ness strea m (VPRFS-h mpSrvId-fm Date) 
  16061   "RTN","VPR DJFSG",19, 0)
  16062    ; (most v ariables n amespaced  since call ing variet y of extra cts)
  16063   "RTN","VPR DJFSG",20, 0)
  16064    ;
  16065   "RTN","VPR DJFSG",21, 0)
  16066    K ^TMP("V PRF",$J)
  16067   "RTN","VPR DJFSG",22, 0)
  16068    N VPRFSYS ,VPRFSTRM, VPRFLAST,V PRFDT,VPRF LIM,VPRFSE Q,VPRFIDX, VPRFCNT,SN ODE,STYPE, VPRFERR,VP RDEL,VPRER R,VPRSTGET
  16069   "RTN","VPR DJFSG",23, 0)
  16070    S VPRFRSP =$NA(^TMP( "VPRF",$J) )
  16071   "RTN","VPR DJFSG",24, 0)
  16072    S VPRFSYS =$$GET^XPA R("SYS","V PR SYSTEM  NAME") ; T ODO -- swi tch to VPR SYS
  16073   "RTN","VPR DJFSG",25, 0)
  16074    I '$L(VPR FHMP) D SE TERR^VPRDJ FS("Missin g HMP Serv er ID") Q
  16075   "RTN","VPR DJFSG",26, 0)
  16076    S VPRFHMP ("ien")=$O (^VPR(560, "B",VPRFHM P,0))
  16077   "RTN","VPR DJFSG",27, 0)
  16078    S VPRFDT= $P($G(ARGS ("lastUpda te")),"-")
  16079   "RTN","VPR DJFSG",28, 0)
  16080    S VPRFSEQ =+$P($G(AR GS("lastUp date")),"- ",2)
  16081   "RTN","VPR DJFSG",29, 0)
  16082    S VPRSTGE T=$G(ARGS( "getStatus "))
  16083   "RTN","VPR DJFSG",30, 0)
  16084    ; stream  goes back  a maximum  of 2 days
  16085   "RTN","VPR DJFSG",31, 0)
  16086    I VPRFDT< $$FMADD^XL FDT($$DT^X LFDT,-2) S  VPRFDT=$$ HTFM^XLFDT (+$H-2),VP RFSEQ=0
  16087   "RTN","VPR DJFSG",32, 0)
  16088    S VPRFLAS T=VPRFDT_" -"_VPRFSEQ
  16089   "RTN","VPR DJFSG",33, 0)
  16090    D LASTUPD (VPRFHMP,V PRFLAST)
  16091   "RTN","VPR DJFSG",34, 0)
  16092    S VPRFLIM =$G(ARGS(" max"),9999 9)
  16093   "RTN","VPR DJFSG",35, 0)
  16094    S VPRFSTR M="VPRFS~" _VPRFHMP_" ~"_VPRFDT        ; st ream ident ifier
  16095   "RTN","VPR DJFSG",36, 0)
  16096    S ^XTMP(V PRFSTRM,"j ob",$J)=""                     ;  record jo b number
  16097   "RTN","VPR DJFSG",37, 0)
  16098    S VPRFCNT =0,VPRFIDX =VPRFSEQ
  16099   "RTN","VPR DJFSG",38, 0)
  16100    F  D  Q:V PRFCNT'<VP RFLIM  D N XTSTRM Q:V PRFSTRM=""
  16101   "RTN","VPR DJFSG",39, 0)
  16102    . F  S VP RFIDX=$O(^ XTMP(VPRFS TRM,VPRFID X)) Q:'VPR FIDX  D  Q :VPRFCNT'< VPRFLIM
  16103   "RTN","VPR DJFSG",40, 0)
  16104    . . S SNO DE=^XTMP(V PRFSTRM,VP RFIDX),STY PE=$P(SNOD E,U,2)
  16105   "RTN","VPR DJFSG",41, 0)
  16106    . . S $P( ^XTMP(VPRF STRM,VPRFI DX),U,6)=$ P($H,",",2 ) ; timest amp when s ent
  16107   "RTN","VPR DJFSG",42, 0)
  16108    . . I STY PE="syncNo op" Q                       ; sk ip, patien t was unsu bscribed
  16109   "RTN","VPR DJFSG",43, 0)
  16110    . . I STY PE="syncDo main" D DO MITMS Q          ; ad d multiple  extract i tems
  16111   "RTN","VPR DJFSG",44, 0)
  16112    . . S VPR FSEQ=VPRFI DX
  16113   "RTN","VPR DJFSG",45, 0)
  16114    . . I STY PE="syncEr ror" D SYN CERR(SNODE ,.VPRERR)  Q
  16115   "RTN","VPR DJFSG",46, 0)
  16116    . . I STY PE="syncSt art" D SYN CSTRT(SNOD E) Q  ; be gin initia l extracti on
  16117   "RTN","VPR DJFSG",47, 0)
  16118    . . I STY PE="syncDo ne" D SYNC DONE(SNODE ) Q   ; en d of initi al extract ion
  16119   "RTN","VPR DJFSG",48, 0)
  16120    . . D FRE SHITM(SNOD E,.VPRDEL, .VPRERR)         ; ot herwise, f reshness i tem
  16121   "RTN","VPR DJFSG",49, 0)
  16122    Q:$G(VPRF ERR)
  16123   "RTN","VPR DJFSG",50, 0)
  16124    D FINISH( .VPRDEL,.V PRERR)
  16125   "RTN","VPR DJFSG",51, 0)
  16126    Q
  16127   "RTN","VPR DJFSG",52, 0)
  16128   DOMITMS ;  loop thru  extract it ems, OFFSE T is last  sent
  16129   "RTN","VPR DJFSG",53, 0)
  16130    ; expects  VPRFSTRM, VPRFIDX,VP RFHMP,VPRF SYS
  16131   "RTN","VPR DJFSG",54, 0)
  16132    ; changes  VPRFSEQ,V PRFCNT as  each item  added
  16133   "RTN","VPR DJFSG",55, 0)
  16134    N X,OFFSE T,DFN,PIDS ,DOMAIN,TA SK,BATCH,C OUNT,ITEMN UM,DOMSIZE ,SECSIZE
  16135   "RTN","VPR DJFSG",56, 0)
  16136    S X=^XTMP (VPRFSTRM, VPRFIDX),D FN=$P(X,U) ,X=$P(X,U, 3)
  16137   "RTN","VPR DJFSG",57, 0)
  16138    S PIDS=$S (DFN:$$PID S^VPRDJFS( DFN),1:"")
  16139   "RTN","VPR DJFSG",58, 0)
  16140    S DOMAIN= $P(X,":")                 ; doma in{#sectio nNumber}
  16141   "RTN","VPR DJFSG",59, 0)
  16142    S TASK=$P (X,":",2)                 ; task  number in  ^XTMP
  16143   "RTN","VPR DJFSG",60, 0)
  16144    S COUNT=$ P(X,":",3)                ; coun t in this  section
  16145   "RTN","VPR DJFSG",61, 0)
  16146    S DOMSIZE =$P(X,":", 4)             ; esti mated tota l for the  domain
  16147   "RTN","VPR DJFSG",62, 0)
  16148    S SECSIZE =$P(X,":", 5)             ; sect ion size ( for operat ional)
  16149   "RTN","VPR DJFSG",63, 0)
  16150    S BATCH=" VPRFX~"_VP RFHMP_"~"_ DFN ; extr act node i n ^XTMP
  16151   "RTN","VPR DJFSG",64, 0)
  16152    S OFFSET= COUNT-(VPR FIDX-VPRFS EQ)
  16153   "RTN","VPR DJFSG",65, 0)
  16154    F  S OFFS ET=$O(^XTM P(BATCH,TA SK,DOMAIN, OFFSET)) Q :'OFFSET   D  Q:VPRFC NT'<VPRFLI M
  16155   "RTN","VPR DJFSG",66, 0)
  16156    . S VPRFC NT=VPRFCNT +1             ; incr ement the  count of r eturned it ems
  16157   "RTN","VPR DJFSG",67, 0)
  16158    . S VPRFS EQ=VPRFSEQ +1             ; incr ement the  sequence n umber in t he stream
  16159   "RTN","VPR DJFSG",68, 0)
  16160    . S ITEMN UM=OFFSET+ ($P(DOMAIN ,"#",2)*SE CSIZE)
  16161   "RTN","VPR DJFSG",69, 0)
  16162    . M ^TMP( "VPRF",$J, VPRFCNT)=^ XTMP(BATCH ,TASK,DOMA IN,OFFSET)
  16163   "RTN","VPR DJFSG",70, 0)
  16164    . S ^TMP( "VPRF",$J, VPRFCNT,.3 )=$$WRAPPE R(DOMAIN,P IDS,$S('CO UNT:0,1:IT EMNUM),+DO MSIZE)
  16165   "RTN","VPR DJFSG",71, 0)
  16166    Q
  16167   "RTN","VPR DJFSG",72, 0)
  16168   MIDXTRCT()  ; Return  true if mi d-extract
  16169   "RTN","VPR DJFSG",73, 0)
  16170    ; from GE TSUB expec ts VPRFSTR M,VPRFSEQ
  16171   "RTN","VPR DJFSG",74, 0)
  16172    I 'VPRFSE Q Q 0
  16173   "RTN","VPR DJFSG",75, 0)
  16174    I '$D(^XT MP(VPRFSTR M,VPRFSEQ) ) Q 1                    ; middl e of extra ct
  16175   "RTN","VPR DJFSG",76, 0)
  16176    I $P(^XTM P(VPRFSTRM ,VPRFSEQ), U,2)="sync Domain" Q  1  ; just  starting e xtract
  16177   "RTN","VPR DJFSG",77, 0)
  16178    Q 0
  16179   "RTN","VPR DJFSG",78, 0)
  16180    ;
  16181   "RTN","VPR DJFSG",79, 0)
  16182   NXTSTRM ;  Reset vari ables for  next date  in this HM P stream
  16183   "RTN","VPR DJFSG",80, 0)
  16184    ; from GE TSUB expec ts VPRFSTR M,VPRFDT,V PRFIDX
  16185   "RTN","VPR DJFSG",81, 0)
  16186    ; VPRFSTR M set to " " if no ne xt stream
  16187   "RTN","VPR DJFSG",82, 0)
  16188    ; VPRFIDX   set to 0  if next s tream, or  left as is
  16189   "RTN","VPR DJFSG",83, 0)
  16190    ; VPRFDT    set to l ast date a ctually us ed
  16191   "RTN","VPR DJFSG",84, 0)
  16192    N NEXTDT, DONE
  16193   "RTN","VPR DJFSG",85, 0)
  16194    S NEXTDT= VPRFDT,DON E=0
  16195   "RTN","VPR DJFSG",86, 0)
  16196    F  D  Q:D ONE
  16197   "RTN","VPR DJFSG",87, 0)
  16198    . S NEXTD T=$$FMADD^ XLFDT(NEXT DT,1)
  16199   "RTN","VPR DJFSG",88, 0)
  16200    . I NEXTD T>$$DT^XLF DT S VPRFS TRM="" S D ONE=1 Q
  16201   "RTN","VPR DJFSG",89, 0)
  16202    . S $P(VP RFSTRM,"~" ,3)=NEXTDT
  16203   "RTN","VPR DJFSG",90, 0)
  16204    . I '+$O( ^XTMP(VPRF STRM,0)) Q   ; nothin g here, tr y next dat e
  16205   "RTN","VPR DJFSG",91, 0)
  16206    . S VPRFD T=NEXTDT,V PRFIDX=0,V PRFSEQ=0,D ONE=1
  16207   "RTN","VPR DJFSG",92, 0)
  16208    Q
  16209   "RTN","VPR DJFSG",93, 0)
  16210   FINISH(VPR DEL,VPRERR ) ;reset t he FIRST o bject deli miter, add  header an d tail
  16211   "RTN","VPR DJFSG",94, 0)
  16212    ; expects  VPRFCNT,V PRFDT,VPRF SEQ,VPRFHM P,VPRFLAST
  16213   "RTN","VPR DJFSG",95, 0)
  16214    N CLOSE,I ,START,TEX T,UID,X,II
  16215   "RTN","VPR DJFSG",96, 0)
  16216    S X=$G(^T MP("VPRF", $J,1,.3))
  16217   "RTN","VPR DJFSG",97, 0)
  16218    I $E(X,1, 2)="}," S  X=$E(X,3,$ L(X)),^TMP ("VPRF",$J ,1,.3)=X
  16219   "RTN","VPR DJFSG",98, 0)
  16220    S ^TMP("V PRF",$J,.5 )=$$APIHDR (VPRFCNT,V PRFDT_"-"_ VPRFSEQ)
  16221   "RTN","VPR DJFSG",99, 0)
  16222    ;delete n ode
  16223   "RTN","VPR DJFSG",100 ,0)
  16224    I $D(VPRD EL) D
  16225   "RTN","VPR DJFSG",101 ,0)
  16226    .S CLOSE= $S(VPRFCNT :"},",1:"" ),START=1
  16227   "RTN","VPR DJFSG",102 ,0)
  16228    .;S VPRFC NT=VPRFCNT +1,^TMP("V PRF",$J,VP RFCNT)=CLO SE_"]}"
  16229   "RTN","VPR DJFSG",103 ,0)
  16230    .S VPRFCN T=VPRFCNT+ 1,^TMP("VP RF",$J,VPR FCNT)=CLOS E_"{""dele tes"":["
  16231   "RTN","VPR DJFSG",104 ,0)
  16232    .S UID=""  F  S UID= $O(VPRDEL( UID)) Q:UI D=""  D
  16233   "RTN","VPR DJFSG",105 ,0)
  16234    ..S VPRFC NT=VPRFCNT +1,^TMP("V PRF",$J,VP RFCNT)=$S( START:"",1 :",")_"{"" uid"":"""_ UID_"""}"  S START=0
  16235   "RTN","VPR DJFSG",106 ,0)
  16236    .S VPRFCN T=VPRFCNT+ 1,^TMP("VP RF",$J,VPR FCNT)="]"
  16237   "RTN","VPR DJFSG",107 ,0)
  16238    ;error no de
  16239   "RTN","VPR DJFSG",108 ,0)
  16240    I $D(VPRE RR) D
  16241   "RTN","VPR DJFSG",109 ,0)
  16242    .S CLOSE= $S(VPRFCNT :"},",1:"" ),START=1
  16243   "RTN","VPR DJFSG",110 ,0)
  16244    .;S VPRFC NT=VPRFCNT +1,^TMP("V PRF",$J,VP RFCNT)=CLO SE_"]}"
  16245   "RTN","VPR DJFSG",111 ,0)
  16246    .S VPRFCN T=VPRFCNT+ 1,^TMP("VP RF",$J,VPR FCNT)=CLOS E_"{""erro r"":["
  16247   "RTN","VPR DJFSG",112 ,0)
  16248    .S I=0 F   S I=$O(VP RERR(I)) Q :I'>0  D
  16249   "RTN","VPR DJFSG",113 ,0)
  16250    ..S TEXT= VPRERR(I)
  16251   "RTN","VPR DJFSG",114 ,0)
  16252    ..S VPRFC NT=VPRFCNT +1,^TMP("V PRF",$J,VP RFCNT)=$S( START:"",1 :",")_TEXT  S START=0
  16253   "RTN","VPR DJFSG",115 ,0)
  16254    .S VPRFCN T=VPRFCNT+ 1,^TMP("VP RF",$J,VPR FCNT)="]"
  16255   "RTN","VPR DJFSG",116 ,0)
  16256    S ^TMP("V PRF",$J,VP RFCNT+1)=$ S(VPRFCNT: "}",1:"")_ "]",VPRFCN T=VPRFCNT+ 1
  16257   "RTN","VPR DJFSG",117 ,0)
  16258    I $G(VPRS TGET)="tru e" D
  16259   "RTN","VPR DJFSG",118 ,0)
  16260    . S VPRFC NT=VPRFCNT +1,^TMP("V PRF",$J,VP RFCNT)="," "syncStati i"":[",STA RT=1
  16261   "RTN","VPR DJFSG",119 ,0)
  16262    . S I=0 F   S I=$O(^ VPR(560,I) ) Q:+I=0   D
  16263   "RTN","VPR DJFSG",120 ,0)
  16264    . . I $P( $G(^VPR(56 0,I,0)),"^ ",1)=VPRFH MP D
  16265   "RTN","VPR DJFSG",121 ,0)
  16266    . . . S I I=0 F  S I I=$O(^VPR( 560,I,1,II )) Q:+II=0   D
  16267   "RTN","VPR DJFSG",122 ,0)
  16268    . . . . S  TEXT="{"" pid"":"_II _",""statu s"":"_$P(^ VPR(560,I, 1,II,0),"^ ",2)_"}"
  16269   "RTN","VPR DJFSG",123 ,0)
  16270    . . . . S  VPRFCNT=V PRFCNT+1,^ TMP("VPRF" ,$J,VPRFCN T)=$S(STAR T:"",1:"," )_TEXT S S TART=0
  16271   "RTN","VPR DJFSG",124 ,0)
  16272    . S VPRFC NT=VPRFCNT +1,^TMP("V PRF",$J,VP RFCNT)="]"
  16273   "RTN","VPR DJFSG",125 ,0)
  16274    S ^TMP("V PRF",$J,VP RFCNT+1)=" }}"
  16275   "RTN","VPR DJFSG",126 ,0)
  16276    ;I '$D(VP RDEL),'$D( VPRERR) S  ^TMP("VPRF ",$J,VPRFC NT+1)=$S(V PRFCNT:"}" ,1:"")_"]} }"
  16277   "RTN","VPR DJFSG",127 ,0)
  16278    ;I $D(VPR DEL)!($D(V PRERR)) S  ^TMP("VPRF ",$J,VPRFC NT+1)="}"
  16279   "RTN","VPR DJFSG",128 ,0)
  16280    ;
  16281   "RTN","VPR DJFSG",129 ,0)
  16282    ; remove  any ^XTMP  nodes that  have been  successfu lly sent b ased on LA ST
  16283   "RTN","VPR DJFSG",130 ,0)
  16284    N DATE,SE Q,LASTDT,L ASTSEQ,STR M,LSTRM,RS TRM
  16285   "RTN","VPR DJFSG",131 ,0)
  16286    S LASTDT= +$P(VPRFLA ST,"-"),LA STSEQ=+$P( VPRFLAST," -",2)
  16287   "RTN","VPR DJFSG",132 ,0)
  16288    S RSTRM=" VPRFS~"_VP RFHMP_"~", LSTRM=$L(R STRM),STRM =RSTRM
  16289   "RTN","VPR DJFSG",133 ,0)
  16290    F  S STRM =$O(^XTMP( STRM)) Q:' $L(STRM)   Q:$E(STRM, 1,LSTRM)'= RSTRM  D
  16291   "RTN","VPR DJFSG",134 ,0)
  16292    . S DATE= $P(STRM,"~ ",3) Q:DAT E>LASTDT
  16293   "RTN","VPR DJFSG",135 ,0)
  16294    . S SEQ=0  F  S SEQ= $O(^XTMP(S TRM,"tidy" ,SEQ)) Q:' SEQ  Q:(DA TE=LASTDT) &(SEQ>LAST SEQ)  D TI DYX(STRM,S EQ)
  16295   "RTN","VPR DJFSG",136 ,0)
  16296    Q
  16297   "RTN","VPR DJFSG",137 ,0)
  16298   TIDYX(STRE AM,SEQ) ;  clean up e xtracts af ter they h ave been r etrieved
  16299   "RTN","VPR DJFSG",138 ,0)
  16300    ; from FI NISH
  16301   "RTN","VPR DJFSG",139 ,0)
  16302    N BATCH,D OMAIN,TASK
  16303   "RTN","VPR DJFSG",140 ,0)
  16304    S BATCH=^ XTMP(STREA M,"tidy",S EQ,"batch" )
  16305   "RTN","VPR DJFSG",141 ,0)
  16306    S DOMAIN= ^XTMP(STRE AM,"tidy", SEQ,"domai n")
  16307   "RTN","VPR DJFSG",142 ,0)
  16308    S TASK=^X TMP(STREAM ,"tidy",SE Q,"task")
  16309   "RTN","VPR DJFSG",143 ,0)
  16310    I DOMAIN= "<done>" K  ^XTMP(BAT CH) I 1
  16311   "RTN","VPR DJFSG",144 ,0)
  16312    E  K ^XTM P(BATCH,TA SK,DOMAIN)
  16313   "RTN","VPR DJFSG",145 ,0)
  16314    K ^XTMP(S TREAM,"tid y",SEQ)
  16315   "RTN","VPR DJFSG",146 ,0)
  16316    Q
  16317   "RTN","VPR DJFSG",147 ,0)
  16318   SYNCSTRT(S EQNODE) ;  Build sync Start obje ct with de mograhics
  16319   "RTN","VPR DJFSG",148 ,0)
  16320    ; expects  VPRFSYS,  VPRFHMP, V PRFCNT
  16321   "RTN","VPR DJFSG",149 ,0)
  16322    S VPRFCNT =VPRFCNT+1
  16323   "RTN","VPR DJFSG",150 ,0)
  16324    N DFN,FIL TER,DFN,WR AP
  16325   "RTN","VPR DJFSG",151 ,0)
  16326    S DFN=$P( $P(SEQNODE ,U,3),"~", 3) ; VPRFX ~hmpSrvId~ dfn
  16327   "RTN","VPR DJFSG",152 ,0)
  16328    I DFN D
  16329   "RTN","VPR DJFSG",153 ,0)
  16330    . S FILTE R("patient Id")=DFN,F ILTER("dom ain")="pat ient"
  16331   "RTN","VPR DJFSG",154 ,0)
  16332    . D GET^V PRDJ(.RSLT ,.FILTER)
  16333   "RTN","VPR DJFSG",155 ,0)
  16334    . M ^TMP( "VPRF",$J, VPRFCNT)=^ TMP("VPR", $J,1)
  16335   "RTN","VPR DJFSG",156 ,0)
  16336    ; for OPD  there is  no object,  so 4th ar gument is 
  16337   "RTN","VPR DJFSG",157 ,0)
  16338    S ^TMP("V PRF",$J,VP RFCNT,.3)= $$WRAPPER( "syncStart ",$$PIDS^V PRDJFS(DFN ),$S(DFN:1 ,1:-1),$S( DFN:1,1:-1 ))
  16339   "RTN","VPR DJFSG",158 ,0)
  16340    Q
  16341   "RTN","VPR DJFSG",159 ,0)
  16342   SYNCDONE(S EQNODE) ;  Build sync Status obj ect and st ick in ^TM P
  16343   "RTN","VPR DJFSG",160 ,0)
  16344    ;  expect s: VPRFSYS ,VPRFCNT,  VPRFHMP
  16345   "RTN","VPR DJFSG",161 ,0)
  16346    N VPRBATC H,DFN,VPRB ATCH,STS,S TSJSON,X,E RR
  16347   "RTN","VPR DJFSG",162 ,0)
  16348    S VPRBATC H=$P(SEQNO DE,U,3) ;  VPRFX~hmpS rvId~dfn
  16349   "RTN","VPR DJFSG",163 ,0)
  16350    S DFN=$P( VPRBATCH," ~",3)
  16351   "RTN","VPR DJFSG",164 ,0)
  16352    S STS("ui d")="urn:v a:syncStat us:"_VPRFS YS_":"_DFN
  16353   "RTN","VPR DJFSG",165 ,0)
  16354    S STS("in itialized" )="true"
  16355   "RTN","VPR DJFSG",166 ,0)
  16356    I DFN S S TS("localI d")=DFN
  16357   "RTN","VPR DJFSG",167 ,0)
  16358    S X="" F   S X=$O(^X TMP(VPRBAT CH,0,"coun t",X)) Q:' $L(X)  D
  16359   "RTN","VPR DJFSG",168 ,0)
  16360    . S STS(" domainTota ls",X)=^XT MP(VPRBATC H,0,"count ",X)
  16361   "RTN","VPR DJFSG",169 ,0)
  16362    D ENCODE^ VPRJSON("S TS","STSJS ON","ERR")
  16363   "RTN","VPR DJFSG",170 ,0)
  16364    I $D(ERR)  S $EC=",U JSON encod e error,"  Q
  16365   "RTN","VPR DJFSG",171 ,0)
  16366    S VPRFCNT =VPRFCNT+1
  16367   "RTN","VPR DJFSG",172 ,0)
  16368    M ^TMP("V PRF",$J,VP RFCNT)=STS JSON
  16369   "RTN","VPR DJFSG",173 ,0)
  16370    S ^TMP("V PRF",$J,VP RFCNT,.3)= $$WRAPPER( "syncStatu s",$$PIDS^ VPRDJFS(DF N),1,1)
  16371   "RTN","VPR DJFSG",174 ,0)
  16372    Q
  16373   "RTN","VPR DJFSG",175 ,0)
  16374    ;
  16375   "RTN","VPR DJFSG",176 ,0)
  16376   SYNCERR(SN ODE,VPRERR ) ;
  16377   "RTN","VPR DJFSG",177 ,0)
  16378    ;M ^AGP(" snode")=SN ODE
  16379   "RTN","VPR DJFSG",178 ,0)
  16380    N BATCH,C NT,DFN,NUM ,OFFSET,PI DS,TASK,TO TAL,X
  16381   "RTN","VPR DJFSG",179 ,0)
  16382    S DFN=$P( SNODE,U),X =$P(SNODE, U,3)
  16383   "RTN","VPR DJFSG",180 ,0)
  16384    S PIDS=$$ PIDS^VPRDJ FS(DFN)
  16385   "RTN","VPR DJFSG",181 ,0)
  16386    S TASK=$P (X,":",2), TOTAL=$P(X ,":",4)
  16387   "RTN","VPR DJFSG",182 ,0)
  16388    S BATCH=" VPRFX~"_VP RFHMP_"~"_ DFN        ; extract  node in ^X TMP
  16389   "RTN","VPR DJFSG",183 ,0)
  16390    ;S OFFSET =TOTAL-(VP RFIDX-VPRF SEQ)
  16391   "RTN","VPR DJFSG",184 ,0)
  16392    ;S OFFSET =.9                               ; skip no des < 1
  16393   "RTN","VPR DJFSG",185 ,0)
  16394    ;I 'VPRFC NT S OFFSE T=VPRFIDX- VPRFSEQ+.9  ; in case  starting  mid-extrac t
  16395   "RTN","VPR DJFSG",186 ,0)
  16396    S CNT=$O( VPRERR("") ,-1)
  16397   "RTN","VPR DJFSG",187 ,0)
  16398    S NUM=0 F   S NUM=$O (^XTMP(BAT CH,TASK,"e rror",NUM) ) Q:NUM'>0   D
  16399   "RTN","VPR DJFSG",188 ,0)
  16400    .S CNT=CN T+1 S VPRE RR(CNT)=$G (^XTMP(BAT CH,TASK,"e rror",NUM, 1))
  16401   "RTN","VPR DJFSG",189 ,0)
  16402    . ;M ^TMP ("VPRF",$J ,VPRFCNT)= ^XTMP(BATC H,TASK,DOM AIN,OFFSET )
  16403   "RTN","VPR DJFSG",190 ,0)
  16404    . ;S ^TMP ("VPRF",$J ,VPRFCNT,. 3)=$$WRAPP ER(DOMAIN, PID,$S('TO TAL:0,1:OF FSET),+TOT AL)
  16405   "RTN","VPR DJFSG",191 ,0)
  16406    ;I $G(ERR VAL)="" Q
  16407   "RTN","VPR DJFSG",192 ,0)
  16408    ;S ERRVAL ="{"_ERRVA L_"}"
  16409   "RTN","VPR DJFSG",193 ,0)
  16410    ;D DECODE ^VPRJSON(" ERRVAL","E RROBJ","ER R")
  16411   "RTN","VPR DJFSG",194 ,0)
  16412    ;I $D(ERR ) M ^AGP(" ERR")=ERR
  16413   "RTN","VPR DJFSG",195 ,0)
  16414    ;I $D(ERR ) S $EC=", UJSON deco de error,"
  16415   "RTN","VPR DJFSG",196 ,0)
  16416    ;K ^XTMP( VPRBATCH,V PRFZTSK,DO MAIN,"erro r")
  16417   "RTN","VPR DJFSG",197 ,0)
  16418    ;S ERRMSG =ERROBJ("e rror","mes sage")
  16419   "RTN","VPR DJFSG",198 ,0)
  16420    ;Q:'$L(ER RMSG)
  16421   "RTN","VPR DJFSG",199 ,0)
  16422    ;S SYNCER R("uid")=" urn:va:syn cError:"_V PRFSYS_":" _DFN_":"_D OMAIN
  16423   "RTN","VPR DJFSG",200 ,0)
  16424    ;S SYNCER R("collect ion")=DOMA IN
  16425   "RTN","VPR DJFSG",201 ,0)
  16426    ;S SYNCER R("error") =ERRMSG
  16427   "RTN","VPR DJFSG",202 ,0)
  16428    ;D ENCODE ^VPRJSON(" SYNCERR"," ERRJSON"," ERR") I $D (ERR) S $E C=",UJSON  encode err or,"
  16429   "RTN","VPR DJFSG",203 ,0)
  16430    ;D POST^V PRDJFS(DFN ,"syncErro r","error: "_VPRFZTSK _":1:1","" ,HMPSRV)
  16431   "RTN","VPR DJFSG",204 ,0)
  16432    Q
  16433   "RTN","VPR DJFSG",205 ,0)
  16434   FRESHITM(S EQNODE,DEL ETE,ERROR)  ; Get fre shness ite m and stic k in ^TMP
  16435   "RTN","VPR DJFSG",206 ,0)
  16436    ; expects  VPRFSYS,  VPRFHMP
  16437   "RTN","VPR DJFSG",207 ,0)
  16438    N ACT,DFN ,DOMAIN,EC NT,FILTER, ID,RSLT,UI D,VPRI,WRA P
  16439   "RTN","VPR DJFSG",208 ,0)
  16440    S FILTER( "noHead")= 1
  16441   "RTN","VPR DJFSG",209 ,0)
  16442    S DFN=$P( SEQNODE,U) ,DOMAIN=$P (SEQNODE,U ,2),ID=$P( SEQNODE,U, 3),ACT=$P( SEQNODE,U, 4)
  16443   "RTN","VPR DJFSG",210 ,0)
  16444    I ACT="@"  D  Q
  16445   "RTN","VPR DJFSG",211 ,0)
  16446    . S UID=$ $SETUID^VP RUTILS(DOM AIN,$S(+DF N>0:DFN,1: ""),ID)
  16447   "RTN","VPR DJFSG",212 ,0)
  16448    . S DELET E(UID)=""
  16449   "RTN","VPR DJFSG",213 ,0)
  16450    S FILTER( "id")=ID
  16451   "RTN","VPR DJFSG",214 ,0)
  16452    S FILTER( "domain")= DOMAIN
  16453   "RTN","VPR DJFSG",215 ,0)
  16454    I DFN="OP D" D GET^V PREF(.RSLT ,.FILTER)
  16455   "RTN","VPR DJFSG",216 ,0)
  16456    I +DFN>0  D
  16457   "RTN","VPR DJFSG",217 ,0)
  16458    . S FILTE R("patient Id")=DFN
  16459   "RTN","VPR DJFSG",218 ,0)
  16460    . D GET^V PRDJ(.RSLT ,.FILTER)
  16461   "RTN","VPR DJFSG",219 ,0)
  16462    I $L($G(^ TMP("VPR", $J,"error" )))>0 D BL DSERR(DFN, .ERROR)  Q
  16463   "RTN","VPR DJFSG",220 ,0)
  16464    ;
  16465   "RTN","VPR DJFSG",221 ,0)
  16466    I '$D(^TM P("VPR",$J ,1)) D  Q
  16467   "RTN","VPR DJFSG",222 ,0)
  16468    . S UID=$ $SETUID^VP RUTILS(DOM AIN,$S(+DF N>0:DFN,1: ""),ID)
  16469   "RTN","VPR DJFSG",223 ,0)
  16470    . S DELET E(UID)=""
  16471   "RTN","VPR DJFSG",224 ,0)
  16472    ;
  16473   "RTN","VPR DJFSG",225 ,0)
  16474    S WRAP=$$ WRAPPER(DO MAIN,$$PID S^VPRDJFS( DFN),1,1)
  16475   "RTN","VPR DJFSG",226 ,0)
  16476    F VPRI=1: 1 Q:'$D(^T MP("VPR",$ J,VPRI))   D
  16477   "RTN","VPR DJFSG",227 ,0)
  16478    . S VPRFC NT=VPRFCNT +1
  16479   "RTN","VPR DJFSG",228 ,0)
  16480    . M ^TMP( "VPRF",$J, VPRFCNT)=^ TMP("VPR", $J,VPRI)
  16481   "RTN","VPR DJFSG",229 ,0)
  16482    . S ^TMP( "VPRF",$J, VPRFCNT,.3 )=WRAP
  16483   "RTN","VPR DJFSG",230 ,0)
  16484    Q
  16485   "RTN","VPR DJFSG",231 ,0)
  16486    ;
  16487   "RTN","VPR DJFSG",232 ,0)
  16488   BLDSERR(DF N,ERROR) ;  Create sy ncError ob ject in ER RJSON
  16489   "RTN","VPR DJFSG",233 ,0)
  16490    ; expects : VPRBATCH , VPRFSYS,  VPRFZTSK
  16491   "RTN","VPR DJFSG",234 ,0)
  16492    N COUNT,E RRVAL,ERRO BJ,ERR,ERR MSG,SYNCER R
  16493   "RTN","VPR DJFSG",235 ,0)
  16494    ;S ^XTMP( VPRBATCH,V PRFZTSK,DO MAIN,NODE, .3)="{"  ;  replace ,  with { fo r decoding  JSON
  16495   "RTN","VPR DJFSG",236 ,0)
  16496    M ERRVAL= ^TMP("VPR" ,$J,"error ")
  16497   "RTN","VPR DJFSG",237 ,0)
  16498    I $G(ERRV AL)="" Q
  16499   "RTN","VPR DJFSG",238 ,0)
  16500    S ERRVAL= "{"_ERRVAL _"}"
  16501   "RTN","VPR DJFSG",239 ,0)
  16502    D DECODE^ VPRJSON("E RRVAL","ER ROBJ","ERR ")
  16503   "RTN","VPR DJFSG",240 ,0)
  16504    I $D(ERR)  S $EC=",U JSON decod e error,"
  16505   "RTN","VPR DJFSG",241 ,0)
  16506    S ERRMSG= ERROBJ("er ror","mess age")
  16507   "RTN","VPR DJFSG",242 ,0)
  16508    Q:'$L(ERR MSG)
  16509   "RTN","VPR DJFSG",243 ,0)
  16510    S SYNCERR ("uid")="u rn:va:sync Error:"_VP RFSYS_":"_ DFN_":FRES HNESS"
  16511   "RTN","VPR DJFSG",244 ,0)
  16512    S SYNCERR ("collecti on")=DOMAI N
  16513   "RTN","VPR DJFSG",245 ,0)
  16514    S SYNCERR ("error")= ERRMSG
  16515   "RTN","VPR DJFSG",246 ,0)
  16516    D ENCODE^ VPRJSON("S YNCERR","E RRJSON","E RR") I $D( ERR) S $EC =",UJSON e ncode erro r," Q
  16517   "RTN","VPR DJFSG",247 ,0)
  16518    S COUNT=$ O(ERROR("" ),-1)+1
  16519   "RTN","VPR DJFSG",248 ,0)
  16520    M ERROR(C OUNT)=ERRJ SON
  16521   "RTN","VPR DJFSG",249 ,0)
  16522    Q
  16523   "RTN","VPR DJFSG",250 ,0)
  16524   WRAPPER(DO MAIN,PIDS, OFFSET,DOM SIZE) ; re turn JSON  wrapper fo r each ite m
  16525   "RTN","VPR DJFSG",251 ,0)
  16526    ; add obj ect tag if  extract t otal not z ero or if  total pass ed as -1
  16527   "RTN","VPR DJFSG",252 ,0)
  16528    ; seq and  total tag s only add ed if non- zero
  16529   "RTN","VPR DJFSG",253 ,0)
  16530    N X
  16531   "RTN","VPR DJFSG",254 ,0)
  16532    S X="},{" "collectio n"":"""_$P (DOMAIN,"# ")_""""_PI DS
  16533   "RTN","VPR DJFSG",255 ,0)
  16534    I $G(OFFS ET)>-1 S X =X_",""seq "":"_OFFSE T
  16535   "RTN","VPR DJFSG",256 ,0)
  16536    I $G(DOMS IZE)>-1 S  X=X_",""to tal"":"_DO MSIZE
  16537   "RTN","VPR DJFSG",257 ,0)
  16538    I $G(OFFS ET)>-1 S X =X_",""obj ect"":"
  16539   "RTN","VPR DJFSG",258 ,0)
  16540    Q X
  16541   "RTN","VPR DJFSG",259 ,0)
  16542    ;
  16543   "RTN","VPR DJFSG",260 ,0)
  16544   APIHDR(COU NT,LASTITM ) ; return  JSON
  16545   "RTN","VPR DJFSG",261 ,0)
  16546    ; expects  VPRFSYS
  16547   "RTN","VPR DJFSG",262 ,0)
  16548    N X
  16549   "RTN","VPR DJFSG",263 ,0)
  16550    S X="{""a piVersion" ":1.02,""p arams"":{" "domain"": """_$$KSP^ XUPARAM("W HERE")_""" "
  16551   "RTN","VPR DJFSG",264 ,0)
  16552    S X=X_"," "systemId" ":"""_VPRF SYS_"""}," "data"":{" "updated"" :"""_$$HL7 NOW^VPRDJ_ """"
  16553   "RTN","VPR DJFSG",265 ,0)
  16554    S X=X_"," "totalItem s"":"_COUN T_",""last Update"":" ""_LASTITM _""""_$$PR OGRESS^VPR DJFS(LASTI TM)
  16555   "RTN","VPR DJFSG",266 ,0)
  16556    S X=X_"," "items"":[ "
  16557   "RTN","VPR DJFSG",267 ,0)
  16558    Q X
  16559   "RTN","VPR DJFSG",268 ,0)
  16560    ;
  16561   "RTN","VPR DJFSG",269 ,0)
  16562   LASTUPD(HM PSRV,LASTU PD) ; save  the last  update
  16563   "RTN","VPR DJFSG",270 ,0)
  16564    ; TODO: c hange this  to use Fi leman call
  16565   "RTN","VPR DJFSG",271 ,0)
  16566    N IEN,CUR RUPD,REPEA T
  16567   "RTN","VPR DJFSG",272 ,0)
  16568    S IEN=$O( ^VPR(560," B",HMPSRV, 0)) Q:'IEN
  16569   "RTN","VPR DJFSG",273 ,0)
  16570    Q:LASTUPD ["^"
  16571   "RTN","VPR DJFSG",274 ,0)
  16572    S CURRUPD =$P(^VPR(5 60,IEN,0), "^",2),REP EAT=$P(^VP R(560,IEN, 0),"^",4)
  16573   "RTN","VPR DJFSG",275 ,0)
  16574    I LASTUPD =CURRUPD S  $P(^VPR(5 60,IEN,0), "^",4)=REP EAT+1 QUIT
  16575   "RTN","VPR DJFSG",276 ,0)
  16576    S $P(^VPR (560,IEN,0 ),"^",2)=L ASTUPD,$P( ^VPR(560,I EN,0),"^", 4)=0
  16577   "RTN","VPR DJFSG",277 ,0)
  16578    Q
  16579   "RTN","VPR DJFSG",278 ,0)
  16580   JSONOUT ;  Write out  JSON in ^T MP
  16581   "RTN","VPR DJFSG",279 ,0)
  16582    N X
  16583   "RTN","VPR DJFSG",280 ,0)
  16584    S X=$NA(^ TMP("VPRF" ,$J))
  16585   "RTN","VPR DJFSG",281 ,0)
  16586    F  S X=$Q (@X) Q:($Q S(X,1)'="V PRF")!($QS (X,2)'=$J)   W !,@X
  16587   "RTN","VPR DJFSG",282 ,0)
  16588    Q
  16589   "RTN","VPR DJFSM")
  16590   0^99^B4963 9419
  16591   "RTN","VPR DJFSM",1,0 )
  16592   VPRDJFSM ; SLC/KCM --  Monitorin g Tools fo r Extracts
  16593   "RTN","VPR DJFSM",2,0 )
  16594    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  16595   "RTN","VPR DJFSM",3,0 )
  16596    ;
  16597   "RTN","VPR DJFSM",4,0 )
  16598   EN ; Show  informatio n for one  server
  16599   "RTN","VPR DJFSM",5,0 )
  16600    N IEN
  16601   "RTN","VPR DJFSM",6,0 )
  16602    S IEN=$$G ETSRV() Q: IEN'>0
  16603   "RTN","VPR DJFSM",7,0 )
  16604    D LOOP(IE N)
  16605   "RTN","VPR DJFSM",8,0 )
  16606    Q
  16607   "RTN","VPR DJFSM",9,0 )
  16608   ALL ; Show  informati on for all  servers
  16609   "RTN","VPR DJFSM",10, 0)
  16610    S IEN=0 F   S IEN=$O (^VPR(560, IEN)) Q:'I EN  W ! D  SHOWSRV(IE N)
  16611   "RTN","VPR DJFSM",11, 0)
  16612    Q
  16613   "RTN","VPR DJFSM",12, 0)
  16614   ADDPT(PAT)  ; Add pat ient to se rver
  16615   "RTN","VPR DJFSM",13, 0)
  16616    N SRV,ARG S,RESULT
  16617   "RTN","VPR DJFSM",14, 0)
  16618    I '$G(PAT ) S PAT=$$ GETPAT() Q :'PAT
  16619   "RTN","VPR DJFSM",15, 0)
  16620    S SRV=$$G ETSRV() Q: SRV'>0
  16621   "RTN","VPR DJFSM",16, 0)
  16622    I $G(^VPR (560,"AITE M",PAT,SRV ))>0 W !," Patient "_ PAT_" alre ady synced ."
  16623   "RTN","VPR DJFSM",17, 0)
  16624    ;
  16625   "RTN","VPR DJFSM",18, 0)
  16626    S ARGS("c ommand")=" putPtSubsc ription"
  16627   "RTN","VPR DJFSM",19, 0)
  16628    S ARGS("s erver")=$P (^VPR(560, SRV,0),"^" )
  16629   "RTN","VPR DJFSM",20, 0)
  16630    S ARGS("l ocalId")=P AT
  16631   "RTN","VPR DJFSM",21, 0)
  16632    D API^VPR DJFS(.RESU LT,.ARGS)
  16633   "RTN","VPR DJFSM",22, 0)
  16634    I ^TMP("V PRF",$J,1) ["location " W !,$P($ G(^DPT(PAT ,0)),"^"), " is being  synced."
  16635   "RTN","VPR DJFSM",23, 0)
  16636    E  W !,"S ubscriptio n failed."
  16637   "RTN","VPR DJFSM",24, 0)
  16638    Q
  16639   "RTN","VPR DJFSM",25, 0)
  16640    ;
  16641   "RTN","VPR DJFSM",26, 0)
  16642   LOOP(SRV)  ; Monitor  refresh lo op
  16643   "RTN","VPR DJFSM",27, 0)
  16644    D HOME^%Z IS
  16645   "RTN","VPR DJFSM",28, 0)
  16646    N ACT,IEN
  16647   "RTN","VPR DJFSM",29, 0)
  16648    S ACT="R"  F  D  Q:" RV"'[ACT
  16649   "RTN","VPR DJFSM",30, 0)
  16650    . I ACT=" R" D SHOWM AIN(SRV)
  16651   "RTN","VPR DJFSM",31, 0)
  16652    . I ACT=" V" D SHOWV PRN
  16653   "RTN","VPR DJFSM",32, 0)
  16654    . W ! S A CT=$$GETCM D
  16655   "RTN","VPR DJFSM",33, 0)
  16656    Q
  16657   "RTN","VPR DJFSM",34, 0)
  16658   GETSRV() ;  Return th e IEN for  the server  to monito r
  16659   "RTN","VPR DJFSM",35, 0)
  16660    N DIC,Y
  16661   "RTN","VPR DJFSM",36, 0)
  16662    S DIC="^V PR(560,",D IC(0)="AEM Q",DIC("A" )="Select  HMP server  instance:  "
  16663   "RTN","VPR DJFSM",37, 0)
  16664    D ^DIC
  16665   "RTN","VPR DJFSM",38, 0)
  16666    Q +Y
  16667   "RTN","VPR DJFSM",39, 0)
  16668    ;
  16669   "RTN","VPR DJFSM",40, 0)
  16670   GETPAT() ;  Return DF N for a pa tient
  16671   "RTN","VPR DJFSM",41, 0)
  16672    N DIC,Y
  16673   "RTN","VPR DJFSM",42, 0)
  16674    S DIC="^D PT(",DIC(0 )="AEMQ"
  16675   "RTN","VPR DJFSM",43, 0)
  16676    D ^DIC
  16677   "RTN","VPR DJFSM",44, 0)
  16678    Q +Y
  16679   "RTN","VPR DJFSM",45, 0)
  16680    ;
  16681   "RTN","VPR DJFSM",46, 0)
  16682   GETCMD() ;  Get the n ext comman d
  16683   "RTN","VPR DJFSM",47, 0)
  16684    N X,Y,DIR ,DTOUT,DUO UT,DIRUT,D IROUT
  16685   "RTN","VPR DJFSM",48, 0)
  16686    S DIR(0)= "SB^R:Refr esh;V:View  VPR Nodes ;Q:Quit"
  16687   "RTN","VPR DJFSM",49, 0)
  16688    S DIR("B" )="Refresh "
  16689   "RTN","VPR DJFSM",50, 0)
  16690    D ^DIR
  16691   "RTN","VPR DJFSM",51, 0)
  16692    I $D(DIRU T)!$D(DIRO UT) S Y="Q "
  16693   "RTN","VPR DJFSM",52, 0)
  16694    Q Y
  16695   "RTN","VPR DJFSM",53, 0)
  16696    ;
  16697   "RTN","VPR DJFSM",54, 0)
  16698   SHOWVPRN ;  Show VPR  global nod es
  16699   "RTN","VPR DJFSM",55, 0)
  16700    W !!,"Cur rent VPR t emporary n odes",?40, "High Nume ric or Las t Subscrip t",!
  16701   "RTN","VPR DJFSM",56, 0)
  16702    N X,Y,J
  16703   "RTN","VPR DJFSM",57, 0)
  16704    S X="VPQ~ " F  S X=$ O(^XTMP(X) ) Q:$E(X,1 ,3)'="VPR"   D
  16705   "RTN","VPR DJFSM",58, 0)
  16706    . W !,"^X TMP("""_X_ """)"
  16707   "RTN","VPR DJFSM",59, 0)
  16708    . S Y=$O( ^XTMP(X,"  "),-1) S:' $L(Y) Y=$O (^XTMP(X," "),-1) W ? 40,Y
  16709   "RTN","VPR DJFSM",60, 0)
  16710    W !
  16711   "RTN","VPR DJFSM",61, 0)
  16712    S X="VPQ~ " F  S X=$ O(^TMP(X))  Q:$E(X,1, 3)'="VPR"   D
  16713   "RTN","VPR DJFSM",62, 0)
  16714    . S J=0 F   S J=$O(^ TMP(X,J))  Q:'J  D
  16715   "RTN","VPR DJFSM",63, 0)
  16716    . . W !," ^TMP("""_X _""","_J_" )"
  16717   "RTN","VPR DJFSM",64, 0)
  16718    . . S Y=$ O(^TMP(X,J ," "),-1)  S:'$L(Y) Y =$O(^TMP(X ,J,""),-1)  W ?40,Y
  16719   "RTN","VPR DJFSM",65, 0)
  16720    S J=0 F   S J=$O(^TM P(J)) Q:'J   D
  16721   "RTN","VPR DJFSM",66, 0)
  16722    . S X="VP Q~" F  S X =$O(^TMP(J ,X)) Q:$E( X,1,3)'="V PR"  D
  16723   "RTN","VPR DJFSM",67, 0)
  16724    . . W !," ^TMP("_J_" ,"""_X_""" )"
  16725   "RTN","VPR DJFSM",68, 0)
  16726    . . S Y=$ O(^TMP(J,X ," "),-1)  S:'$L(Y) Y =$O(^TMP(J ,X,""),-1)  W ?40,Y
  16727   "RTN","VPR DJFSM",69, 0)
  16728    Q
  16729   "RTN","VPR DJFSM",70, 0)
  16730   SHOWMAIN(S RV) ; Show  main info rmation fo r server
  16731   "RTN","VPR DJFSM",71, 0)
  16732    N STREAM
  16733   "RTN","VPR DJFSM",72, 0)
  16734    S STREAM= $$LSTREAM( SRV)
  16735   "RTN","VPR DJFSM",73, 0)
  16736    W @IOF
  16737   "RTN","VPR DJFSM",74, 0)
  16738    W !,$$HTE ^XLFDT($H) ,?64,"Slot s Open: ", $$SLOTS,!
  16739   "RTN","VPR DJFSM",75, 0)
  16740    I STREAM= "" W !,"No  VPR extra ct stream  found." Q
  16741   "RTN","VPR DJFSM",76, 0)
  16742    D SHOWSRV (SRV)
  16743   "RTN","VPR DJFSM",77, 0)
  16744    D LJOBS(S RV)
  16745   "RTN","VPR DJFSM",78, 0)
  16746    D LQUEUE( SRV,10)
  16747   "RTN","VPR DJFSM",79, 0)
  16748    Q 
  16749   "RTN","VPR DJFSM",80, 0)
  16750   SHOWSRV(IE N) ; Show  informatio n for a se rver
  16751   "RTN","VPR DJFSM",81, 0)
  16752    N X0,ROOT ,BATCH,STR EAM,SRVNM, LASTUP,REP EAT,TASK,T ASKS
  16753   "RTN","VPR DJFSM",82, 0)
  16754    S X0=^VPR (560,IEN,0 )
  16755   "RTN","VPR DJFSM",83, 0)
  16756    S SRVNM=$ P(X0,"^"), LASTUP=$P( X0,"^",2), REPEAT=$P( X0,"^",4)
  16757   "RTN","VPR DJFSM",84, 0)
  16758    S STREAM= $$LSTREAM( SRV)
  16759   "RTN","VPR DJFSM",85, 0)
  16760    W !,SRVNM ,?30,"Last  Update: " ,LASTUP W: REPEAT "   x",REPEAT
  16761   "RTN","VPR DJFSM",86, 0)
  16762    I $D(^XTM P(STREAM))  D
  16763   "RTN","VPR DJFSM",87, 0)
  16764    . W !,?29 ,"End of Q ueue: ",$P (STREAM,"~ ",3),"-",$ G(^XTMP(ST REAM,"last "))
  16765   "RTN","VPR DJFSM",88, 0)
  16766    ; loop th ru extract s for this  server
  16767   "RTN","VPR DJFSM",89, 0)
  16768    S ROOT="V PRFX~"_SRV NM_"~",BAT CH=ROOT
  16769   "RTN","VPR DJFSM",90, 0)
  16770    S BATCH=R OOT F  S B ATCH=$O(^X TMP(BATCH) ) Q:$E(BAT CH,1,$L(RO OT))'=ROOT   D
  16771   "RTN","VPR DJFSM",91, 0)
  16772    . W !,$J( $P(BATCH," ~",3),12)
  16773   "RTN","VPR DJFSM",92, 0)
  16774    . S TASK= 0,TASKS=""
  16775   "RTN","VPR DJFSM",93, 0)
  16776    . F  S TA SK=$O(^XTM P(BATCH,0, "task",TAS K)) Q:'TAS K  S TASKS =TASKS_$S( $L(TASKS): ",",1:"")_ TASK
  16777   "RTN","VPR DJFSM",94, 0)
  16778    . W ?14," Task(s)"_T ASKS
  16779   "RTN","VPR DJFSM",95, 0)
  16780    . I '$D(^ XTMP(BATCH ,0,"wait") ) W ?34,"w aiting: ", $$WAIT(BAT CH)," seco nds" Q
  16781   "RTN","VPR DJFSM",96, 0)
  16782    . W ?31," extracting : ",$$LOBJ (BATCH,TAS K)
  16783   "RTN","VPR DJFSM",97, 0)
  16784    Q
  16785   "RTN","VPR DJFSM",98, 0)
  16786   WAIT(BATCH ) ; Return  the numbe r of secon ds the bat ch has bee n waiting
  16787   "RTN","VPR DJFSM",99, 0)
  16788    N START
  16789   "RTN","VPR DJFSM",100 ,0)
  16790    S START=$ G(^XTMP(BA TCH,0,"tim e")) Q:'ST ART 0
  16791   "RTN","VPR DJFSM",101 ,0)
  16792    Q $$HDIFF ^XLFDT($H, START,2)
  16793   "RTN","VPR DJFSM",102 ,0)
  16794    ;
  16795   "RTN","VPR DJFSM",103 ,0)
  16796   LOBJ(BATCH ,TASK) ; R eturn the  last domai n>count re trieved fo r this bat ch
  16797   "RTN","VPR DJFSM",104 ,0)
  16798    Q:'TASK " no task"
  16799   "RTN","VPR DJFSM",105 ,0)
  16800    N LASTITM ,DOMAIN,NU M
  16801   "RTN","VPR DJFSM",106 ,0)
  16802    S LASTITM =""
  16803   "RTN","VPR DJFSM",107 ,0)
  16804    S DOMAIN= "",LASTITM =""
  16805   "RTN","VPR DJFSM",108 ,0)
  16806    F  S DOMA IN=$O(^XTM P(BATCH,0, "status",D OMAIN)) Q: '$L(DOMAIN )  D  Q:$L (LASTITM)
  16807   "RTN","VPR DJFSM",109 ,0)
  16808    . I $G(^X TMP(BATCH, 0,"status" ,DOMAIN))  Q  ; domai n complete
  16809   "RTN","VPR DJFSM",110 ,0)
  16810    . S NUM=$ O(^XTMP(BA TCH,TASK,D OMAIN,""), -1)
  16811   "RTN","VPR DJFSM",111 ,0)
  16812    . S LASTI TM=DOMAIN_ $S(NUM:" # "_NUM,1:"" )
  16813   "RTN","VPR DJFSM",112 ,0)
  16814    Q $S('$L( LASTITM):" <finished> ",1:LASTIT M)
  16815   "RTN","VPR DJFSM",113 ,0)
  16816    ;
  16817   "RTN","VPR DJFSM",114 ,0)
  16818   SLOTS() ;  Return the  number of  slots ava ilable
  16819   "RTN","VPR DJFSM",115 ,0)
  16820    N OUT
  16821   "RTN","VPR DJFSM",116 ,0)
  16822    D FIND^DI C(3.54,"", "1","BX"," VPR EXTRAC T RESOURCE ","","","" ,"","OUT")
  16823   "RTN","VPR DJFSM",117 ,0)
  16824    Q $G(OUT( "DILIST"," ID",1,1))
  16825   "RTN","VPR DJFSM",118 ,0)
  16826    ;
  16827   "RTN","VPR DJFSM",119 ,0)
  16828   LJOBS(SRV)  ; Show jo bs polling  in this s tream
  16829   "RTN","VPR DJFSM",120 ,0)
  16830    N STREAM, X,JOBNUM
  16831   "RTN","VPR DJFSM",121 ,0)
  16832    S STREAM= $$LSTREAM( SRV),X=""
  16833   "RTN","VPR DJFSM",122 ,0)
  16834    S JOBNUM= "" F  S JO BNUM=$O(^X TMP(STREAM ,"job",JOB NUM)) Q:'J OBNUM  D
  16835   "RTN","VPR DJFSM",123 ,0)
  16836    . S X=X_$ S($L(X):",  ",1:"")_J OBNUM
  16837   "RTN","VPR DJFSM",124 ,0)
  16838    W !!,"Pol ling job n umber(s):   "_X
  16839   "RTN","VPR DJFSM",125 ,0)
  16840    Q
  16841   "RTN","VPR DJFSM",126 ,0)
  16842   LQUEUE(SRV ,MAX) ; Sh ow last MA X items in  freshness  queue
  16843   "RTN","VPR DJFSM",127 ,0)
  16844    W !!,"Las t items in  the queue  ---"
  16845   "RTN","VPR DJFSM",128 ,0)
  16846    N CNT,SEQ ,LIST,STRE AM
  16847   "RTN","VPR DJFSM",129 ,0)
  16848    S STREAM= $$LSTREAM( SRV)
  16849   "RTN","VPR DJFSM",130 ,0)
  16850    S CNT=0,S EQ=" " ; r everse fro m space to  get numer ic entries
  16851   "RTN","VPR DJFSM",131 ,0)
  16852    F  S SEQ= $O(^XTMP(S TREAM,SEQ) ,-1) Q:'SE Q  D  Q:CN T>9
  16853   "RTN","VPR DJFSM",132 ,0)
  16854    . S CNT=C NT+1
  16855   "RTN","VPR DJFSM",133 ,0)
  16856    . S LIST( SEQ)=^XTMP (STREAM,SE Q)
  16857   "RTN","VPR DJFSM",134 ,0)
  16858    S SEQ=""  F  S SEQ=$ O(LIST(SEQ )) Q:'SEQ   W !,SEQ,? 8,LIST(SEQ )
  16859   "RTN","VPR DJFSM",135 ,0)
  16860    Q
  16861   "RTN","VPR DJFSM",136 ,0)
  16862   LSTREAM(SR V) ; Retur n the late st stream  for this s erver
  16863   "RTN","VPR DJFSM",137 ,0)
  16864    N STREAM
  16865   "RTN","VPR DJFSM",138 ,0)
  16866    S STREAM= "VPRFS~"_$ P($G(^VPR( 560,SRV,0) ),"^")_"~9 999999"
  16867   "RTN","VPR DJFSM",139 ,0)
  16868    S STREAM= $O(^XTMP(S TREAM),-1)
  16869   "RTN","VPR DJFSM",140 ,0)
  16870    Q STREAM
  16871   "RTN","VPR DJFSM",141 ,0)
  16872    ;
  16873   "RTN","VPR DJFSM",142 ,0)
  16874   EMERSTOP ;  Emergency  Stop for  Freshness
  16875   "RTN","VPR DJFSM",143 ,0)
  16876    D SETFRUP (0)
  16877   "RTN","VPR DJFSM",144 ,0)
  16878    Q
  16879   "RTN","VPR DJFSM",145 ,0)
  16880   RSTRTFR ;  Re-start f reshness u pdates
  16881   "RTN","VPR DJFSM",146 ,0)
  16882    D SETFRUP (1)
  16883   "RTN","VPR DJFSM",147 ,0)
  16884    Q
  16885   "RTN","VPR DJFSM",148 ,0)
  16886   SETFRUP(ST ART) ; Set  flag for  freshness  updates
  16887   "RTN","VPR DJFSM",149 ,0)
  16888    I 'START  D
  16889   "RTN","VPR DJFSM",150 ,0)
  16890    . W !,"WA RNING!  Th is will st op freshne ss updates  for the V PR."
  16891   "RTN","VPR DJFSM",151 ,0)
  16892    . W !,"           It  will be n ecessary t o re-synch  patient d ata.",!
  16893   "RTN","VPR DJFSM",152 ,0)
  16894    I START D
  16895   "RTN","VPR DJFSM",153 ,0)
  16896    . W !,"Th is will -- RESUME-- f reshness u pdates for  the VPR."
  16897   "RTN","VPR DJFSM",154 ,0)
  16898    . W !,"It  may be ne cessary to  re-synch  patient an d operatio nal data." ,!
  16899   "RTN","VPR DJFSM",155 ,0)
  16900    N TYPLST, ALPHA,I,TY PE
  16901   "RTN","VPR DJFSM",156 ,0)
  16902    D EVNTYPS (.TYPLST)
  16903   "RTN","VPR DJFSM",157 ,0)
  16904    S I=0 F   S I=$O(TYP LST(I)) Q: 'I  S ALPH A(TYPLST(I ))=""
  16905   "RTN","VPR DJFSM",158 ,0)
  16906    S TYPE=$$ GETFTYP(.A LPHA,START )
  16907   "RTN","VPR DJFSM",159 ,0)
  16908    Q:TYPE=""
  16909   "RTN","VPR DJFSM",160 ,0)
  16910    I TYPE="* " D  Q
  16911   "RTN","VPR DJFSM",161 ,0)
  16912    . S TYPE= "" F  S TY PE=$O(ALPH A(TYPE)) Q :TYPE=""   D CHGFTYP( TYPE,START )
  16913   "RTN","VPR DJFSM",162 ,0)
  16914    D CHGFTYP (TYPE,STAR T)
  16915   "RTN","VPR DJFSM",163 ,0)
  16916    Q
  16917   "RTN","VPR DJFSM",164 ,0)
  16918   CHGFTYP(TY PE,START)  ; Change t he freshne ss update  flag for a  type
  16919   "RTN","VPR DJFSM",165 ,0)
  16920    I START D  STRTFTYP( TYPE) Q
  16921   "RTN","VPR DJFSM",166 ,0)
  16922    ; otherwi se
  16923   "RTN","VPR DJFSM",167 ,0)
  16924    D STOPFTY P(TYPE)
  16925   "RTN","VPR DJFSM",168 ,0)
  16926    Q
  16927   "RTN","VPR DJFSM",169 ,0)
  16928   STOPFTYP(T YPE) ; Sto p freshnes s updates  for type
  16929   "RTN","VPR DJFSM",170 ,0)
  16930    I '$D(^XT MP("VPR-of f",0)) D N EWXTMP^VPR DJFS("VPR- off",999," Switch off  VPR fresh ness updat es")
  16931   "RTN","VPR DJFSM",171 ,0)
  16932    W !,"Stop ping fresh ess update s for: ",T YPE
  16933   "RTN","VPR DJFSM",172 ,0)
  16934    S ^XTMP(" VPR-off",T YPE)=1
  16935   "RTN","VPR DJFSM",173 ,0)
  16936    Q
  16937   "RTN","VPR DJFSM",174 ,0)
  16938   STRTFTYP(T YPE) ; Res ume freshn ess update s for type
  16939   "RTN","VPR DJFSM",175 ,0)
  16940    W !,"Resu ming fresh ness updat es for: ", TYPE
  16941   "RTN","VPR DJFSM",176 ,0)
  16942    K ^XTMP(" VPR-off",T YPE)
  16943   "RTN","VPR DJFSM",177 ,0)
  16944    Q
  16945   "RTN","VPR DJFSM",178 ,0)
  16946   GETFTYP(AL PHA,START)  ; Return  item from  the list
  16947   "RTN","VPR DJFSM",179 ,0)
  16948    N X,T,P
  16949   "RTN","VPR DJFSM",180 ,0)
  16950    S P=$S(ST ART:"start ",1:"stop" )
  16951   "RTN","VPR DJFSM",181 ,0)
  16952    F  D  Q:X '["?"
  16953   "RTN","VPR DJFSM",182 ,0)
  16954    . D SHOWF TYP(.ALPHA )
  16955   "RTN","VPR DJFSM",183 ,0)
  16956    . W !!,"C hoose doma in to "_P_ " (* "_P_" s all): "
  16957   "RTN","VPR DJFSM",184 ,0)
  16958    . R X:300  S:$E(X)=" ^" X="" Q: X=""  Q:X= "*"
  16959   "RTN","VPR DJFSM",185 ,0)
  16960    . S X=$$L OW^XLFSTR( X)
  16961   "RTN","VPR DJFSM",186 ,0)
  16962    . Q:$D(AL PHA(X))
  16963   "RTN","VPR DJFSM",187 ,0)
  16964    . S T=$O( ALPHA(X))
  16965   "RTN","VPR DJFSM",188 ,0)
  16966    . I X=$E( T,1,$L(X))  W "  ",T  S X=T Q
  16967   "RTN","VPR DJFSM",189 ,0)
  16968    . W "  ?? ",! S X="? "
  16969   "RTN","VPR DJFSM",190 ,0)
  16970    Q X
  16971   "RTN","VPR DJFSM",191 ,0)
  16972    ;
  16973   "RTN","VPR DJFSM",192 ,0)
  16974   SHOWFTYP(A LPHA) ; Sh ow freshne ss types
  16975   "RTN","VPR DJFSM",193 ,0)
  16976    N I,X,P
  16977   "RTN","VPR DJFSM",194 ,0)
  16978    S I=0,X=" " F  S X=$ O(ALPHA(X) ) Q:'$L(X)   D
  16979   "RTN","VPR DJFSM",195 ,0)
  16980    . S I=I+1 ,P=I#3
  16981   "RTN","VPR DJFSM",196 ,0)
  16982    . W:P=1 ! ,X
  16983   "RTN","VPR DJFSM",197 ,0)
  16984    . W:P=2 ? 26,X
  16985   "RTN","VPR DJFSM",198 ,0)
  16986    . W:P=0 ? 52,X
  16987   "RTN","VPR DJFSM",199 ,0)
  16988    Q
  16989   "RTN","VPR DJFSM",200 ,0)
  16990   EVNTYPS(LI ST) ; load  event typ es
  16991   "RTN","VPR DJFSM",201 ,0)
  16992    ;;allergy
  16993   "RTN","VPR DJFSM",202 ,0)
  16994    ;;med
  16995   "RTN","VPR DJFSM",203 ,0)
  16996    ;;auxilia ry
  16997   "RTN","VPR DJFSM",204 ,0)
  16998    ;;appoint ment
  16999   "RTN","VPR DJFSM",205 ,0)
  17000    ;;diagnos is
  17001   "RTN","VPR DJFSM",206 ,0)
  17002    ;;documen t
  17003   "RTN","VPR DJFSM",207 ,0)
  17004    ;;factor
  17005   "RTN","VPR DJFSM",208 ,0)
  17006    ;;immuniz ation
  17007   "RTN","VPR DJFSM",209 ,0)
  17008    ;;lab
  17009   "RTN","VPR DJFSM",210 ,0)
  17010    ;;obs
  17011   "RTN","VPR DJFSM",211 ,0)
  17012    ;;order
  17013   "RTN","VPR DJFSM",212 ,0)
  17014    ;;problem
  17015   "RTN","VPR DJFSM",213 ,0)
  17016    ;;procedu re
  17017   "RTN","VPR DJFSM",214 ,0)
  17018    ;;consult
  17019   "RTN","VPR DJFSM",215 ,0)
  17020    ;;image
  17021   "RTN","VPR DJFSM",216 ,0)
  17022    ;;surgery
  17023   "RTN","VPR DJFSM",217 ,0)
  17024    ;;task
  17025   "RTN","VPR DJFSM",218 ,0)
  17026    ;;visit
  17027   "RTN","VPR DJFSM",219 ,0)
  17028    ;;vital
  17029   "RTN","VPR DJFSM",220 ,0)
  17030    ;;mh
  17031   "RTN","VPR DJFSM",221 ,0)
  17032    ;;ptf
  17033   "RTN","VPR DJFSM",222 ,0)
  17034    ;;exam
  17035   "RTN","VPR DJFSM",223 ,0)
  17036    ;;cpt
  17037   "RTN","VPR DJFSM",224 ,0)
  17038    ;;educati on
  17039   "RTN","VPR DJFSM",225 ,0)
  17040    ;;pov
  17041   "RTN","VPR DJFSM",226 ,0)
  17042    ;;skin
  17043   "RTN","VPR DJFSM",227 ,0)
  17044    ;;treatme nt
  17045   "RTN","VPR DJFSM",228 ,0)
  17046    ;;roadtri p
  17047   "RTN","VPR DJFSM",229 ,0)
  17048    ;;diet
  17049   "RTN","VPR DJFSM",230 ,0)
  17050    ;;pt-sele ct
  17051   "RTN","VPR DJFSM",231 ,0)
  17052    ;;patient
  17053   "RTN","VPR DJFSM",232 ,0)
  17054    ;;roster
  17055   "RTN","VPR DJFSM",233 ,0)
  17056    ;;user
  17057   "RTN","VPR DJFSM",234 ,0)
  17058    ;;zzzzz
  17059   "RTN","VPR DJFSM",235 ,0)
  17060    N I,X
  17061   "RTN","VPR DJFSM",236 ,0)
  17062    F I=1:1 S  X=$P($T(E VNTYPS+I), ";;",2,99)  Q:X="zzzz z"  S LIST (I)=X
  17063   "RTN","VPR DJFSM",237 ,0)
  17064    Q
  17065   "RTN","VPR DJFSM",238 ,0)
  17066    ;
  17067   "RTN","VPR DJFSP")
  17068   0^87^B1408 22334
  17069   "RTN","VPR DJFSP",1,0 )
  17070   VPRDJFSP ; SLC/KCM --  PUT/POST  for Extrac t and Fres hness Stre am
  17071   "RTN","VPR DJFSP",2,0 )
  17072    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  17073   "RTN","VPR DJFSP",3,0 )
  17074    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  17075   "RTN","VPR DJFSP",4,0 )
  17076    ;
  17077   "RTN","VPR DJFSP",5,0 )
  17078    ;
  17079   "RTN","VPR DJFSP",6,0 )
  17080    ; --- cre ate a new  patient su bscription
  17081   "RTN","VPR DJFSP",7,0 )
  17082    ;
  17083   "RTN","VPR DJFSP",8,0 )
  17084   PUTSUB(ARG S) ; retur n location  after cre ating a ne w subscrip tion
  17085   "RTN","VPR DJFSP",9,0 )
  17086    ;  fn ret urns       : /vpr/sub scription/ {hmpSrvId} /patient/{ sysId;dfn}
  17087   "RTN","VPR DJFSP",10, 0)
  17088    ;                    : "" if er ror, error s in ^TMP( "VPRFERR", $J)
  17089   "RTN","VPR DJFSP",11, 0)
  17090    ; .ARGS(" server")   : name of  HMP server
  17091   "RTN","VPR DJFSP",12, 0)
  17092    ; .ARGS(" localId")  : dfn for  patient to  subscribe  or "OPD"  (operation al data)
  17093   "RTN","VPR DJFSP",13, 0)
  17094    ; .ARGS(" icn")      : icn for  patient to  subscribe
  17095   "RTN","VPR DJFSP",14, 0)
  17096    ; .ARGS(" domains")  : optional  array of  domains to  initializ e (depreca ted)
  17097   "RTN","VPR DJFSP",15, 0)
  17098    ;
  17099   "RTN","VPR DJFSP",16, 0)
  17100    I '$$TM^% ZTLOAD D S ETERR^VPRD JFS("Taskm an not run ning") Q " "
  17101   "RTN","VPR DJFSP",17, 0)
  17102    ;
  17103   "RTN","VPR DJFSP",18, 0)
  17104    N HMPSRV, VPRFDFN,VP RBATCH,VPR FERR,NEWSU B,DOMAINS
  17105   "RTN","VPR DJFSP",19, 0)
  17106    ;
  17107   "RTN","VPR DJFSP",20, 0)
  17108    ; make su re we can  identify t he patient  ("OPD" si gnals sync  operation al)
  17109   "RTN","VPR DJFSP",21, 0)
  17110    S VPRFDFN =$G(ARGS(" localId"))
  17111   "RTN","VPR DJFSP",22, 0)
  17112    I VPRFDFN '="OPD" D   Q:$G(VPRF ERR) ""
  17113   "RTN","VPR DJFSP",23, 0)
  17114    . I '$L(V PRFDFN),$L (ARGS("icn ")) S VPRF DFN=+$$GET DFN^MPIF00 1(ARGS("ic n"))
  17115   "RTN","VPR DJFSP",24, 0)
  17116    . I 'VPRF DFN D SETE RR^VPRDJFS ("No patie nt specifi ed") Q
  17117   "RTN","VPR DJFSP",25, 0)
  17118    . I '$D(^ DPT(VPRFDF N)) D SETE RR^VPRDJFS ("Patient  not found" )
  17119   "RTN","VPR DJFSP",26, 0)
  17120    ;
  17121   "RTN","VPR DJFSP",27, 0)
  17122    ; make su re server  is known a nd create  batch id
  17123   "RTN","VPR DJFSP",28, 0)
  17124    S HMPSRV= VPRFHMP  ;  TODO: swi tch to VPR FHMP as se rver ien
  17125   "RTN","VPR DJFSP",29, 0)
  17126    I '$L(HMP SRV) D SET ERR^VPRDJF S("Missing  HMP Serve r ID") Q " "
  17127   "RTN","VPR DJFSP",30, 0)
  17128    S HMPSRV( "ien")=$O( ^VPR(560," B",HMPSRV, 0))
  17129   "RTN","VPR DJFSP",31, 0)
  17130    I 'HMPSRV ("ien") D  SETERR^VPR DJFS("HMP  Server not  registere d") Q ""
  17131   "RTN","VPR DJFSP",32, 0)
  17132    S VPRBATC H="VPRFX~" _HMPSRV_"~ "_VPRFDFN
  17133   "RTN","VPR DJFSP",33, 0)
  17134    ;
  17135   "RTN","VPR DJFSP",34, 0)
  17136    ; set up  domains to  extract
  17137   "RTN","VPR DJFSP",35, 0)
  17138    D @($S(VP RFDFN="OPD ":"OPDOMS" ,1:"PTDOMS ")_"^VPRDJ FSD(.DOMAI NS)")
  17139   "RTN","VPR DJFSP",36, 0)
  17140    ;
  17141   "RTN","VPR DJFSP",37, 0)
  17142    ; see if  this is ne w subscrip tion and t ask extrac t if new
  17143   "RTN","VPR DJFSP",38, 0)
  17144    D SETPAT( VPRFDFN,HM PSRV,.NEWS UB) Q:$G(V PRFERR) ""
  17145   "RTN","VPR DJFSP",39, 0)
  17146    I NEWSUB  D  Q:$G(VP RFERR) ""
  17147   "RTN","VPR DJFSP",40, 0)
  17148    . I VPRFD FN="OPD" D                          ; queue  each oper ational do main
  17149   "RTN","VPR DJFSP",41, 0)
  17150    . . S I=" " F  S I=$ O(DOMAINS( I)) Q:'I   D
  17151   "RTN","VPR DJFSP",42, 0)
  17152    . . . N V PRFDOM
  17153   "RTN","VPR DJFSP",43, 0)
  17154    . . . S V PRFDOM(1)= DOMAINS(I)
  17155   "RTN","VPR DJFSP",44, 0)
  17156    . . . D Q UINIT(VPRB ATCH,VPRFD FN,.VPRFDO M)
  17157   "RTN","VPR DJFSP",45, 0)
  17158    . E  D                                        ; queue  all domai ns for pat ient
  17159   "RTN","VPR DJFSP",46, 0)
  17160    . . N VPR FDOM
  17161   "RTN","VPR DJFSP",47, 0)
  17162    . . M VPR FDOM=DOMAI NS
  17163   "RTN","VPR DJFSP",48, 0)
  17164    . . D QUI NIT(VPRBAT CH,VPRFDFN ,.VPRFDOM)
  17165   "RTN","VPR DJFSP",49, 0)
  17166    Q "/vpr/s ubscriptio n/"_HMPSRV _"/patient /"_$$PID^V PRDJFS(VPR FDFN) ;_"? task="_$O( ^XTMP(VPRB ATCH,0,"ta sk",0))
  17167   "RTN","VPR DJFSP",50, 0)
  17168    ;
  17169   "RTN","VPR DJFSP",51, 0)
  17170   QUINIT(VPR BATCH,VPRF DFN,VPRFDO M) ; Queue  the initi al extract s for a pa tient
  17171   "RTN","VPR DJFSP",52, 0)
  17172    ; VPRBATC H="VPRFX~h mpsrvid~df n"  exampl e: VPRFX~h mpXYZ~229
  17173   "RTN","VPR DJFSP",53, 0)
  17174    ; VPRFDOM (n)="domai nName"
  17175   "RTN","VPR DJFSP",54, 0)
  17176    ; 
  17177   "RTN","VPR DJFSP",55, 0)
  17178    ; ^XTMP(" VPRFX~hmps rvid~dfn", 0)=expires ^created^V PR Patient  Extract
  17179   "RTN","VPR DJFSP",56, 0)
  17180    ;                             , 0,"status" ,domain)=0 :waiting;1 :ready
  17181   "RTN","VPR DJFSP",57, 0)
  17182    ;                             , 0,"task",t askIen)=""
  17183   "RTN","VPR DJFSP",58, 0)
  17184    ;                             , taskIen,do main,... ( extract da ta)
  17185   "RTN","VPR DJFSP",59, 0)
  17186    ;
  17187   "RTN","VPR DJFSP",60, 0)
  17188    ; only do ne once wh en beginni ng the bat ch, no mat ter how ma ny tasked  jobs
  17189   "RTN","VPR DJFSP",61, 0)
  17190    L +^XTMP( VPRBATCH): 5 E  D SET ERR^VPRDJF S("Cannot  lock batch :"_VPRBATC H) QUIT
  17191   "RTN","VPR DJFSP",62, 0)
  17192    I '$D(^XT MP(VPRBATC H)) D
  17193   "RTN","VPR DJFSP",63, 0)
  17194    . D NEWXT MP^VPRDJFS (VPRBATCH, 2,"VPR Pat ient Extra ct")
  17195   "RTN","VPR DJFSP",64, 0)
  17196    . S ^XTMP (VPRBATCH, 0,"time")= $H
  17197   "RTN","VPR DJFSP",65, 0)
  17198    . D SETMA RK("Start" ,VPRFDFN,V PRBATCH) ;  sends ful l demograp hics
  17199   "RTN","VPR DJFSP",66, 0)
  17200    L -^XTMP( VPRBATCH)
  17201   "RTN","VPR DJFSP",67, 0)
  17202    ;
  17203   "RTN","VPR DJFSP",68, 0)
  17204    ; set up  the domain s to be do ne by this  task
  17205   "RTN","VPR DJFSP",69, 0)
  17206    N I S I=0  F  S I=$O (VPRFDOM(I )) Q:'I  D  SETDOM("s tatus",VPR FDOM(I),0)
  17207   "RTN","VPR DJFSP",70, 0)
  17208    ;
  17209   "RTN","VPR DJFSP",71, 0)
  17210    ; now cre ate the ta sk for thi s set of d omains wit hin the ba tch
  17211   "RTN","VPR DJFSP",72, 0)
  17212    N ZTRTN,Z TDESC,ZTDT H,ZTIO,ZTU CI,ZTCPU,Z TPRI,ZTSAV E,ZTKIL,ZT SYNC,ZTSK
  17213   "RTN","VPR DJFSP",73, 0)
  17214    S ZTRTN=" DQINIT^VPR DJFSP",ZTI O="VPR EXT RACT RESOU RCE",ZTDTH =$H
  17215   "RTN","VPR DJFSP",74, 0)
  17216    S ZTSAVE( "VPRBATCH" )="",ZTSAV E("VPRFDFN ")="",ZTSA VE("VPRFDO M(")=""
  17217   "RTN","VPR DJFSP",75, 0)
  17218    S ZTDESC= "Build VPR  domains f or a patie nt"
  17219   "RTN","VPR DJFSP",76, 0)
  17220    D ^%ZTLOA D
  17221   "RTN","VPR DJFSP",77, 0)
  17222    ;
  17223   "RTN","VPR DJFSP",78, 0)
  17224    I $G(ZTSK ) S ^XTMP( VPRBATCH,0 ,"task",ZT SK)="" I 1
  17225   "RTN","VPR DJFSP",79, 0)
  17226    E  D SETE RR^VPRDJFS ("Task not  created")
  17227   "RTN","VPR DJFSP",80, 0)
  17228    Q
  17229   "RTN","VPR DJFSP",81, 0)
  17230   SETDOM(ATT RIB,DOMAIN ,VALUE) ;  Set value  for a doma in
  17231   "RTN","VPR DJFSP",82, 0)
  17232    ; ATTRIB:  "status"  or "count"  attribute
  17233   "RTN","VPR DJFSP",83, 0)
  17234    ; for sta tus, VALUE : 0=waitin g, 1=ready
  17235   "RTN","VPR DJFSP",84, 0)
  17236    ; for cou nt,  VALUE : count of  items
  17237   "RTN","VPR DJFSP",85, 0)
  17238    S ^XTMP(V PRBATCH,0, ATTRIB,DOM AIN)=VALUE
  17239   "RTN","VPR DJFSP",86, 0)
  17240    Q
  17241   "RTN","VPR DJFSP",87, 0)
  17242   SETMARK(TY PE,VPRFDFN ,VPRBATCH)  ; Post ma rkers for  begin and  end of ini tial synch
  17243   "RTN","VPR DJFSP",88, 0)
  17244    ; ^XTMP(" VPRFP","ti dy",hmpSer ver,fmDate ,sequence) =batch
  17245   "RTN","VPR DJFSP",89, 0)
  17246    N HPMSRV, NODES,X
  17247   "RTN","VPR DJFSP",90, 0)
  17248    S HMPSRV= $P(VPRBATC H,"~",2)
  17249   "RTN","VPR DJFSP",91, 0)
  17250    D POST^VP RDJFS(VPRF DFN,"sync" _TYPE,VPRB ATCH,"",HM PSRV,.NODE S)
  17251   "RTN","VPR DJFSP",92, 0)
  17252    Q:TYPE="S tart"
  17253   "RTN","VPR DJFSP",93, 0)
  17254    D SETTIDY ("<done>", .NODES)
  17255   "RTN","VPR DJFSP",94, 0)
  17256    Q
  17257   "RTN","VPR DJFSP",95, 0)
  17258   DQINIT ; D equeue ini tial extra cts
  17259   "RTN","VPR DJFSP",96, 0)
  17260    ; expects :  VPRBATC H, VPRFDFN , VPRFDOM,  ZTSK
  17261   "RTN","VPR DJFSP",97, 0)
  17262    I '$D(^XT MP(VPRBATC H,0,"task" ,ZTSK)) Q   ; extract  was super ceded
  17263   "RTN","VPR DJFSP",98, 0)
  17264    N COUNT,V PRFDOMI,VP RFSYS,VPRF ZTSK
  17265   "RTN","VPR DJFSP",99, 0)
  17266    K ^TMP("V PRERR",$J)
  17267   "RTN","VPR DJFSP",100 ,0)
  17268    S VPRFSYS =$$GET^XPA R("SYS","V PR SYSTEM  NAME")
  17269   "RTN","VPR DJFSP",101 ,0)
  17270    S VPRFZTS K=ZTSK ; j ust in cas e the unex pected hap pens to ZT SK
  17271   "RTN","VPR DJFSP",102 ,0)
  17272    S ^XTMP(V PRBATCH,0, "task",ZTS K,"job")=$ J
  17273   "RTN","VPR DJFSP",103 ,0)
  17274    S ^XTMP(V PRBATCH,0, "task",ZTS K,"wait")= $$HDIFF^XL FDT($H,$G( ^XTMP(VPRB ATCH,0,"ti me")),2)
  17275   "RTN","VPR DJFSP",104 ,0)
  17276    D UPDSTS( VPRFDFN,$P (VPRBATCH, "~",2),1)
  17277   "RTN","VPR DJFSP",105 ,0)
  17278    S VPRFDOM I="" F  S  VPRFDOMI=$ O(VPRFDOM( VPRFDOMI))  Q:'VPRFDO MI  D
  17279   "RTN","VPR DJFSP",106 ,0)
  17280    . I VPRFD FN="OPD" D  DOMOPD(VP RFDOM(VPRF DOMI))
  17281   "RTN","VPR DJFSP",107 ,0)
  17282    . I +VPRF DFN D DOMP T(VPRFDOM( VPRFDOMI))
  17283   "RTN","VPR DJFSP",108 ,0)
  17284    . ; if su perceded,  stop proce ssing doma ins
  17285   "RTN","VPR DJFSP",109 ,0)
  17286    . I '$D(^ XTMP(VPRBA TCH,0,"tas k",VPRFZTS K)) S VPRF DOMI=999 Q
  17287   "RTN","VPR DJFSP",110 ,0)
  17288    . D SETDO M("status" ,VPRFDOM(V PRFDOMI),1 ) ; ready
  17289   "RTN","VPR DJFSP",111 ,0)
  17290    ; if supe rceded, re move extra cts produc ed by this  task
  17291   "RTN","VPR DJFSP",112 ,0)
  17292    I '$D(^XT MP(VPRBATC H,0,"task" ,VPRFZTSK) ) K ^XTMP( VPRBATCH,V PRFZTSK) Q
  17293   "RTN","VPR DJFSP",113 ,0)
  17294    ; don't a ssume init ialized, s ince we ma y split do mains to o ther tasks
  17295   "RTN","VPR DJFSP",114 ,0)
  17296    I $$INITD ONE(VPRBAT CH) D              ;  if all dom ains extra cted
  17297   "RTN","VPR DJFSP",115 ,0)
  17298    . S COUNT =$O(^TMP(" VPRERR",$J ,"")) I CO UNT>0 D PO STERR(COUN T,VPRFDFN)
  17299   "RTN","VPR DJFSP",116 ,0)
  17300    . D SETMA RK("Done", VPRFDFN,VP RBATCH) ;  - add upda ted syncSt atus
  17301   "RTN","VPR DJFSP",117 ,0)
  17302    . D MVFRU PD(VPRBATC H,VPRFDFN)         ;  - move fre shness upd ates over
  17303   "RTN","VPR DJFSP",118 ,0)
  17304    K ^XTMP(V PRBATCH,0, "task",VPR FZTSK)  ;  this task  is done
  17305   "RTN","VPR DJFSP",119 ,0)
  17306    Q
  17307   "RTN","VPR DJFSP",120 ,0)
  17308   DOMPT(VPRF ADOM) ; Lo ad a patie nt domain
  17309   "RTN","VPR DJFSP",121 ,0)
  17310    N FILTER, RSLT,VPRFE ST
  17311   "RTN","VPR DJFSP",122 ,0)
  17312    S FILTER( "noHead")= 1
  17313   "RTN","VPR DJFSP",123 ,0)
  17314    S FILTER( "domain")= VPRFADOM
  17315   "RTN","VPR DJFSP",124 ,0)
  17316    S FILTER( "patientId ")=VPRFDFN
  17317   "RTN","VPR DJFSP",125 ,0)
  17318    D GET^VPR DJ(.RSLT,. FILTER)
  17319   "RTN","VPR DJFSP",126 ,0)
  17320    D MOD4STR M(VPRFADOM )
  17321   "RTN","VPR DJFSP",127 ,0)
  17322    D POSTSEC (VPRFADOM)
  17323   "RTN","VPR DJFSP",128 ,0)
  17324    Q
  17325   "RTN","VPR DJFSP",129 ,0)
  17326   DOMOPD(VPR FADOM) ; L oad an ope rational d omain in s maller bat ches
  17327   "RTN","VPR DJFSP",130 ,0)
  17328    ; expects  VPRBATCH, VPRFZTSK
  17329   "RTN","VPR DJFSP",131 ,0)
  17330    N FILTER, RSLT,NEXTI D,DONE,VPR FEST,VPRFS EC,VPRFSIZ E
  17331   "RTN","VPR DJFSP",132 ,0)
  17332    S VPRFSIZ E=1000                 ; section  size (adj ust to tas te)
  17333   "RTN","VPR DJFSP",133 ,0)
  17334    S VPRFEST =$$TOTAL(V PRFADOM)    ; set est imated dom ain total
  17335   "RTN","VPR DJFSP",134 ,0)
  17336    S NEXTID= 0,VPRFSEC= 0,DONE=0
  17337   "RTN","VPR DJFSP",135 ,0)
  17338    S VPRFADO M=VPRFADOM _"#"_VPRFS EC
  17339   "RTN","VPR DJFSP",136 ,0)
  17340    F  D  Q:D ONE
  17341   "RTN","VPR DJFSP",137 ,0)
  17342    . N FILTE R,RSLT
  17343   "RTN","VPR DJFSP",138 ,0)
  17344    . S FILTE R("noHead" )=1
  17345   "RTN","VPR DJFSP",139 ,0)
  17346    . S FILTE R("domain" )=VPRFADOM  ; include  section f or ^XTMP l ocation
  17347   "RTN","VPR DJFSP",140 ,0)
  17348    . S FILTE R("start") =NEXTID
  17349   "RTN","VPR DJFSP",141 ,0)
  17350    . S FILTE R("limit") =VPRFSIZE
  17351   "RTN","VPR DJFSP",142 ,0)
  17352    . D GET^V PREF(.RSLT ,.FILTER)
  17353   "RTN","VPR DJFSP",143 ,0)
  17354    . I '$D(^ XTMP(VPRBA TCH,0,"tas k",VPRFZTS K)) S DONE =1 QUIT  ;  supercede d
  17355   "RTN","VPR DJFSP",144 ,0)
  17356    . I $G(^X TMP(VPRBAT CH,VPRFZTS K,VPRFADOM ,"total"), 0)=0,(VPRF SEC>0) S D ONE=1 QUIT
  17357   "RTN","VPR DJFSP",145 ,0)
  17358    . I $G(^X TMP(VPRBAT CH,VPRFZTS K,VPRFADOM ,"finished ")) S DONE =1
  17359   "RTN","VPR DJFSP",146 ,0)
  17360    . D MOD4S TRM(VPRFAD OM)
  17361   "RTN","VPR DJFSP",147 ,0)
  17362    . I DONE  S VPRFEST= ^XTMP(VPRB ATCH,0,"co unt",$P(VP RFADOM,"#" )) S:'VPRF EST VPRFES T=1
  17363   "RTN","VPR DJFSP",148 ,0)
  17364    . D POSTS EC(VPRFADO M,VPRFEST, VPRFSIZE)
  17365   "RTN","VPR DJFSP",149 ,0)
  17366    . Q:DONE
  17367   "RTN","VPR DJFSP",150 ,0)
  17368    . S NEXTI D=$G(^XTMP (VPRBATCH, VPRFZTSK,V PRFADOM,"l ast"),0)
  17369   "RTN","VPR DJFSP",151 ,0)
  17370    . S VPRFS EC=VPRFSEC +1
  17371   "RTN","VPR DJFSP",152 ,0)
  17372    . S $P(VP RFADOM,"#" ,2)=VPRFSE C
  17373   "RTN","VPR DJFSP",153 ,0)
  17374    Q
  17375   "RTN","VPR DJFSP",154 ,0)
  17376   MOD4STRM(D OMAIN) ; m odify extr act to be  ready for  stream
  17377   "RTN","VPR DJFSP",155 ,0)
  17378    ; expects : VPRBATCH , VPRFSYS,  VPRFZTSK
  17379   "RTN","VPR DJFSP",156 ,0)
  17380    ; results  are in ^X TMP("VPRFX ~hmpsrv~df n",DFN,DOM AIN,...)
  17381   "RTN","VPR DJFSP",157 ,0)
  17382    ; syncErr or: {uid,c ollection, error}  ui d=urn:va:s yncError:s ysId:dfn:e xtract
  17383   "RTN","VPR DJFSP",158 ,0)
  17384    N DFN,HMP SRV,COUNT, DOMONLY
  17385   "RTN","VPR DJFSP",159 ,0)
  17386    S DOMONLY =$P(DOMAIN ,"#")
  17387   "RTN","VPR DJFSP",160 ,0)
  17388    S DFN=$P( VPRBATCH," ~",3),HMPS RV=$P(VPRB ATCH,"~",2 )
  17389   "RTN","VPR DJFSP",161 ,0)
  17390    S COUNT=+ $G(^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,"total "),0)
  17391   "RTN","VPR DJFSP",162 ,0)
  17392    I COUNT=0  S ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,1,1)=" null"
  17393   "RTN","VPR DJFSP",163 ,0)
  17394    ; if erro r, add syn cError obj ect (from  COUNT+2)
  17395   "RTN","VPR DJFSP",164 ,0)
  17396    I $D(^XTM P(VPRBATCH ,VPRFZTSK, DOMAIN,"er ror")) D
  17397   "RTN","VPR DJFSP",165 ,0)
  17398    . N JSON
  17399   "RTN","VPR DJFSP",166 ,0)
  17400    . ;D BLDS ERR(DFN,DO MAIN,.JSON ) Q:'$D(JS ON)
  17401   "RTN","VPR DJFSP",167 ,0)
  17402    . ;S COUN T=COUNT+1
  17403   "RTN","VPR DJFSP",168 ,0)
  17404    . ;S ^XTM P(VPRBATCH ,VPRFZTSK, DOMAIN,COU NT,1)=","
  17405   "RTN","VPR DJFSP",169 ,0)
  17406    . ;M ^XTM P(VPRBATCH ,VPRFZTSK, DOMAIN,COU NT,1)=JSON
  17407   "RTN","VPR DJFSP",170 ,0)
  17408    S ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,"total ")=COUNT     ;incl er rors and/o r empty
  17409   "RTN","VPR DJFSP",171 ,0)
  17410    D SETDOM( "count",DO MONLY,$G(^ XTMP(VPRBA TCH,0,"cou nt",DOMONL Y),0)+COUN T)
  17411   "RTN","VPR DJFSP",172 ,0)
  17412    Q
  17413   "RTN","VPR DJFSP",173 ,0)
  17414   POSTSEC(DO MAIN,ETOTA L,SECSIZE)  ; post do main secti on to stre am and set  tidy node s
  17415   "RTN","VPR DJFSP",174 ,0)
  17416    N DFN,HMP SRV,COUNT, X,NODES
  17417   "RTN","VPR DJFSP",175 ,0)
  17418    S COUNT=^ XTMP(VPRBA TCH,VPRFZT SK,DOMAIN, "total")
  17419   "RTN","VPR DJFSP",176 ,0)
  17420    S ETOTAL= $G(ETOTAL, COUNT)
  17421   "RTN","VPR DJFSP",177 ,0)
  17422    s SECSIZE =$G(SECSIZ E,0)
  17423   "RTN","VPR DJFSP",178 ,0)
  17424    S DFN=$P( VPRBATCH," ~",3)
  17425   "RTN","VPR DJFSP",179 ,0)
  17426    S HMPSRV= $P(VPRBATC H,"~",2)
  17427   "RTN","VPR DJFSP",180 ,0)
  17428    D POST^VP RDJFS(DFN, "syncDomai n",DOMAIN_ ":"_VPRFZT SK_":"_COU NT_":"_ETO TAL_":"_SE CSIZE,"",H MPSRV,.NOD ES)
  17429   "RTN","VPR DJFSP",181 ,0)
  17430    D SETTIDY (DOMAIN,.N ODES)
  17431   "RTN","VPR DJFSP",182 ,0)
  17432    Q
  17433   "RTN","VPR DJFSP",183 ,0)
  17434   SETTIDY(DO MAIN,NODES ) ; Set ti dy nodes f or clean-u p of the e xtracts in  ^XTMP
  17435   "RTN","VPR DJFSP",184 ,0)
  17436    ; expects  VPRBATCH, VPRFZTSK
  17437   "RTN","VPR DJFSP",185 ,0)
  17438    N X,STREA M,SEQ
  17439   "RTN","VPR DJFSP",186 ,0)
  17440    S X="" F   S X=$O(NO DES(X)) Q: X=""  D       ; itera te hmp ser vers
  17441   "RTN","VPR DJFSP",187 ,0)
  17442    . S STREA M="VPRFS~" _X_"~"_$P( NODES(X),U )  ; VPRFS ~hmpSrv~fm Date
  17443   "RTN","VPR DJFSP",188 ,0)
  17444    . S SEQ=$ P(NODES(X) ,U,2)
  17445   "RTN","VPR DJFSP",189 ,0)
  17446    . S ^XTMP (STREAM,"t idy",SEQ," batch")=VP RBATCH
  17447   "RTN","VPR DJFSP",190 ,0)
  17448    . S ^XTMP (STREAM,"t idy",SEQ," domain")=D OMAIN
  17449   "RTN","VPR DJFSP",191 ,0)
  17450    . S ^XTMP (STREAM,"t idy",SEQ," task")=VPR FZTSK
  17451   "RTN","VPR DJFSP",192 ,0)
  17452    Q
  17453   "RTN","VPR DJFSP",193 ,0)
  17454   MVFRUPD(VP RBATCH,VPR FDFN) ; Mo ve freshne ss updates  over acti ve stream
  17455   "RTN","VPR DJFSP",194 ,0)
  17456    N I,X,FRO M,HMPSRV,D FN,TYPE,ID ,ACT
  17457   "RTN","VPR DJFSP",195 ,0)
  17458    S HMPSRV= $P(VPRBATC H,"~",2)
  17459   "RTN","VPR DJFSP",196 ,0)
  17460    D UPDSTS( VPRFDFN,HM PSRV,2)                ; now ini tialized 
  17461   "RTN","VPR DJFSP",197 ,0)
  17462    S FROM="V PRFH~"_HMP SRV_"~"_VP RFDFN
  17463   "RTN","VPR DJFSP",198 ,0)
  17464    S I=0 F   S I=$O(^XT MP(FROM,I) ) Q:'I  D   ; move ov er held up dates
  17465   "RTN","VPR DJFSP",199 ,0)
  17466    . S X=^XT MP(FROM,I)
  17467   "RTN","VPR DJFSP",200 ,0)
  17468    . S DFN=$ P(X,U),TYP E=$P(X,U,2 ),ID=$P(X, U,3),ACT=$ P(X,U,4)
  17469   "RTN","VPR DJFSP",201 ,0)
  17470    . D POST^ VPRDJFS(DF N,TYPE,ID, ACT,HMPSRV )
  17471   "RTN","VPR DJFSP",202 ,0)
  17472    K ^XTMP(F ROM)
  17473   "RTN","VPR DJFSP",203 ,0)
  17474    Q
  17475   "RTN","VPR DJFSP",204 ,0)
  17476   BLDSERR(DF N,DOMAIN,E RRJSON) ;  Create syn cError obj ect in ERR JSON
  17477   "RTN","VPR DJFSP",205 ,0)
  17478    ; expects : VPRBATCH , VPRFSYS,  VPRFZTSK
  17479   "RTN","VPR DJFSP",206 ,0)
  17480    N COUNT,E RRVAL,ERRO BJ,ERR,ERR MSG,SYNCER R
  17481   "RTN","VPR DJFSP",207 ,0)
  17482    ;S ^XTMP( VPRBATCH,V PRFZTSK,DO MAIN,NODE, .3)="{"  ;  replace ,  with { fo r decoding  JSON
  17483   "RTN","VPR DJFSP",208 ,0)
  17484    M ERRVAL= ^XTMP(VPRB ATCH,VPRFZ TSK,DOMAIN ,"error")
  17485   "RTN","VPR DJFSP",209 ,0)
  17486    I $G(ERRV AL)="" Q
  17487   "RTN","VPR DJFSP",210 ,0)
  17488    S ERRVAL= "{"_ERRVAL _"}"
  17489   "RTN","VPR DJFSP",211 ,0)
  17490    D DECODE^ VPRJSON("E RRVAL","ER ROBJ","ERR ")
  17491   "RTN","VPR DJFSP",212 ,0)
  17492    I $D(ERR)  S $EC=",U JSON decod e error,"
  17493   "RTN","VPR DJFSP",213 ,0)
  17494    K ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,"error ")
  17495   "RTN","VPR DJFSP",214 ,0)
  17496    S ERRMSG= ERROBJ("er ror","mess age")
  17497   "RTN","VPR DJFSP",215 ,0)
  17498    Q:'$L(ERR MSG)
  17499   "RTN","VPR DJFSP",216 ,0)
  17500    S SYNCERR ("uid")="u rn:va:sync Error:"_VP RFSYS_":"_ DFN_":"_DO MAIN
  17501   "RTN","VPR DJFSP",217 ,0)
  17502    S SYNCERR ("collecti on")=DOMAI N
  17503   "RTN","VPR DJFSP",218 ,0)
  17504    S SYNCERR ("error")= ERRMSG
  17505   "RTN","VPR DJFSP",219 ,0)
  17506    D ENCODE^ VPRJSON("S YNCERR","E RRJSON","E RR") I $D( ERR) S $EC =",UJSON e ncode erro r," Q
  17507   "RTN","VPR DJFSP",220 ,0)
  17508    S COUNT=$ O(^TMP("VP RERR",$J," "),-1)+1
  17509   "RTN","VPR DJFSP",221 ,0)
  17510    ;D POST^V PRDJFS(DFN ,"syncErro r","error: "_VPRFZTSK _":1:1","" ,HMPSRV)
  17511   "RTN","VPR DJFSP",222 ,0)
  17512    M ^TMP("V PRERR",$J, COUNT)=ERR JSON
  17513   "RTN","VPR DJFSP",223 ,0)
  17514    Q
  17515   "RTN","VPR DJFSP",224 ,0)
  17516    ;
  17517   "RTN","VPR DJFSP",225 ,0)
  17518   POSTERR(CO UNT,DFN) ;
  17519   "RTN","VPR DJFSP",226 ,0)
  17520    N CNT,NOD E,HMPSRV
  17521   "RTN","VPR DJFSP",227 ,0)
  17522    S HMPSRV= $P(VPRBATC H,"~",2)
  17523   "RTN","VPR DJFSP",228 ,0)
  17524    S CNT=0 F   S CNT=$O (^TMP("VPR ERR",$J,CN T)) Q:CNT' >0  D
  17525   "RTN","VPR DJFSP",229 ,0)
  17526    .S NODE=$ G(^TMP("VP RERR",$J,C NT,1))
  17527   "RTN","VPR DJFSP",230 ,0)
  17528    .S ^XTMP( VPRBATCH,V PRFZTSK,"e rror",CNT, 1)=NODE
  17529   "RTN","VPR DJFSP",231 ,0)
  17530    .I CNT>1  S ^XTMP(VP RBATCH,VPR FZTSK,"err or",CNT,.3 )=","
  17531   "RTN","VPR DJFSP",232 ,0)
  17532    D POST^VP RDJFS(DFN, "syncError ","error:" _VPRFZTSK_ ":"_COUNT_ ":"_COUNT, "",HMPSRV)
  17533   "RTN","VPR DJFSP",233 ,0)
  17534    Q
  17535   "RTN","VPR DJFSP",234 ,0)
  17536    ;
  17537   "RTN","VPR DJFSP",235 ,0)
  17538   INITDONE(V PRBATCH) ;  Return 1  if all dom ains are d one
  17539   "RTN","VPR DJFSP",236 ,0)
  17540    N X,DONE
  17541   "RTN","VPR DJFSP",237 ,0)
  17542    S X="",DO NE=1
  17543   "RTN","VPR DJFSP",238 ,0)
  17544    F  S X=$O (^XTMP(VPR BATCH,0,"s tatus",X))  Q:'$L(X)   I '^(X) S  DONE=0
  17545   "RTN","VPR DJFSP",239 ,0)
  17546    Q DONE
  17547   "RTN","VPR DJFSP",240 ,0)
  17548    ;
  17549   "RTN","VPR DJFSP",241 ,0)
  17550   SETPAT(DFN ,SRV,NEWSU B) ; Add p atient to  560 if not  there
  17551   "RTN","VPR DJFSP",242 ,0)
  17552    N ERR,FDA ,IEN,IENRO OT
  17553   "RTN","VPR DJFSP",243 ,0)
  17554    S IEN=$O( ^VPR(560," B",SRV,0))
  17555   "RTN","VPR DJFSP",244 ,0)
  17556    I 'IEN D  SETERR^VPR DJFS("Unab le to find  server: " _SRV) QUIT
  17557   "RTN","VPR DJFSP",245 ,0)
  17558    ; for ope rational,  only start  sync if n ot yet sub scribed
  17559   "RTN","VPR DJFSP",246 ,0)
  17560    I DFN="OP D" D  QUIT
  17561   "RTN","VPR DJFSP",247 ,0)
  17562    . L +^VPR (560,IEN): 5 E  D SET ERR^VPRDJF S("Unable  to lock se rver: "_SV R) Q
  17563   "RTN","VPR DJFSP",248 ,0)
  17564    . ; statu s is empty  string (n ot 0) when  unsubscri bed
  17565   "RTN","VPR DJFSP",249 ,0)
  17566    . S NEWSU B='$L($P($ G(^VPR(560 ,IEN,0)),U ,3))
  17567   "RTN","VPR DJFSP",250 ,0)
  17568    . I NEWSU B D UPDOPD (IEN,0) ;  set to sub scribed
  17569   "RTN","VPR DJFSP",251 ,0)
  17570    . L -^VPR (560,IEN)
  17571   "RTN","VPR DJFSP",252 ,0)
  17572    ;
  17573   "RTN","VPR DJFSP",253 ,0)
  17574    ; for pat ient, chec k subscrib ed and get  the PID
  17575   "RTN","VPR DJFSP",254 ,0)
  17576    L +^VPR(5 60,IEN,1,D FN):5 E  D  SETERR^VP RDJFS("Una ble to loc k patient:  "_DFN) Q
  17577   "RTN","VPR DJFSP",255 ,0)
  17578    S NEWSUB= '$D(^VPR(5 60,IEN,1,D FN))
  17579   "RTN","VPR DJFSP",256 ,0)
  17580    I NEWSUB  D ADDPAT(D FN,IEN)
  17581   "RTN","VPR DJFSP",257 ,0)
  17582    L -^VPR(5 60,IEN,1,D FN)
  17583   "RTN","VPR DJFSP",258 ,0)
  17584    Q
  17585   "RTN","VPR DJFSP",259 ,0)
  17586    ;
  17587   "RTN","VPR DJFSP",260 ,0)
  17588   UPDOPD(SRV ,STS) ; Up date statu s of opera tional syn ch
  17589   "RTN","VPR DJFSP",261 ,0)
  17590    N FDA,ERR ,DIERR
  17591   "RTN","VPR DJFSP",262 ,0)
  17592    S FDA(560 ,SRV_",",. 03)=STS
  17593   "RTN","VPR DJFSP",263 ,0)
  17594    D FILE^DI E("","FDA" ,"ERR")
  17595   "RTN","VPR DJFSP",264 ,0)
  17596    I $D(ERR)  D SETERR^ VPRDJFS("E rror chang ing operat ional stat us")
  17597   "RTN","VPR DJFSP",265 ,0)
  17598    D CLEAN^D ILF
  17599   "RTN","VPR DJFSP",266 ,0)
  17600    Q
  17601   "RTN","VPR DJFSP",267 ,0)
  17602   ADDPAT(DFN ,SRV) ; Ad d a patien t as subsc ribed for  server
  17603   "RTN","VPR DJFSP",268 ,0)
  17604    N FDA,FDA IEN,DIERR, ERR,IENS
  17605   "RTN","VPR DJFSP",269 ,0)
  17606    S IENS="? +"_DFN_"," _SRV_","
  17607   "RTN","VPR DJFSP",270 ,0)
  17608    S FDAIEN( DFN)=DFN   ; help DIN UM to work
  17609   "RTN","VPR DJFSP",271 ,0)
  17610    S FDA(560 .01,IENS,. 01)=DFN
  17611   "RTN","VPR DJFSP",272 ,0)
  17612    S FDA(560 .01,IENS,2 )=0
  17613   "RTN","VPR DJFSP",273 ,0)
  17614    S FDA(560 .01,IENS,3 )=$$NOW^XL FDT
  17615   "RTN","VPR DJFSP",274 ,0)
  17616    D UPDATE^ DIE("","FD A","FDAIEN ","ERR")
  17617   "RTN","VPR DJFSP",275 ,0)
  17618    I $D(ERR)  D SETERR^ VPRDJFS("E rror addin g patient  subscripti on")
  17619   "RTN","VPR DJFSP",276 ,0)
  17620    D CLEAN^D ILF
  17621   "RTN","VPR DJFSP",277 ,0)
  17622    Q
  17623   "RTN","VPR DJFSP",278 ,0)
  17624   UPDSTS(DFN ,SRVNM,STS ) ; Update  the sync  status
  17625   "RTN","VPR DJFSP",279 ,0)
  17626    N SRV
  17627   "RTN","VPR DJFSP",280 ,0)
  17628    S SRV=$O( ^VPR(560," B",SRVNM,0 )) I 'SRV  D SETERR^V PRDJFS("Mi ssing Serv er") Q
  17629   "RTN","VPR DJFSP",281 ,0)
  17630    I DFN="OP D" D UPDOP D(SRV,STS)  QUIT
  17631   "RTN","VPR DJFSP",282 ,0)
  17632    ;
  17633   "RTN","VPR DJFSP",283 ,0)
  17634    S FDA(560 .01,DFN_", "_SRV_",", 2)=STS
  17635   "RTN","VPR DJFSP",284 ,0)
  17636    S FDA(560 .01,DFN_", "_SRV_",", 3)=$$NOW^X LFDT
  17637   "RTN","VPR DJFSP",285 ,0)
  17638    D FILE^DI E("","FDA" ,"ERR")
  17639   "RTN","VPR DJFSP",286 ,0)
  17640    I $D(ERR)  D SETERR^ VPRDJFS("E rror updat ing patien t sync sta tus")
  17641   "RTN","VPR DJFSP",287 ,0)
  17642    D CLEAN^D ILF
  17643   "RTN","VPR DJFSP",288 ,0)
  17644    Q
  17645   "RTN","VPR DJFSP",289 ,0)
  17646   UPDPAT(DFN ,SRV,STS)  ; DEPRECAT ED?
  17647   "RTN","VPR DJFSP",290 ,0)
  17648    N ERR,FDA ,IEN
  17649   "RTN","VPR DJFSP",291 ,0)
  17650    S IEN=$O( ^VPR(560," B",SRV,"") ) I +IEN'> 0 Q
  17651   "RTN","VPR DJFSP",292 ,0)
  17652    I DFN="OP D" D
  17653   "RTN","VPR DJFSP",293 ,0)
  17654    . S FDA(5 60,"?"_IEN _",",.01)= SRV
  17655   "RTN","VPR DJFSP",294 ,0)
  17656    . S FDA(5 60,"?"_IEN _",",.03)= STS
  17657   "RTN","VPR DJFSP",295 ,0)
  17658    I +DFN>0  D
  17659   "RTN","VPR DJFSP",296 ,0)
  17660    .S FDA(56 0.01,"?"_D FN_","_IEN _",",.01)= DFN
  17661   "RTN","VPR DJFSP",297 ,0)
  17662    .S FDA(56 0.01,"?"_D FN_","_IEN _",",2)=ST S
  17663   "RTN","VPR DJFSP",298 ,0)
  17664    D UPDATE^ DIE("","FD A","","ERR ")
  17665   "RTN","VPR DJFSP",299 ,0)
  17666    ;I $D(ERR ) M ^AGP(" error")=ER R
  17667   "RTN","VPR DJFSP",300 ,0)
  17668    Q
  17669   "RTN","VPR DJFSP",301 ,0)
  17670   TOTAL(DOMA IN) ;
  17671   "RTN","VPR DJFSP",302 ,0)
  17672    N I,X,SIZ E
  17673   "RTN","VPR DJFSP",303 ,0)
  17674    S SIZE=0
  17675   "RTN","VPR DJFSP",304 ,0)
  17676    F I=1:1 S  X=$T(OPDO MS+I^VPRDJ FSD) Q:$P( X,";",3)=" zzzzz"  D   Q:SIZE
  17677   "RTN","VPR DJFSP",305 ,0)
  17678    . I $P(X, ";",3)'=DO MAIN Q
  17679   "RTN","VPR DJFSP",306 ,0)
  17680    . S ROOT= $P(X,";",4 )
  17681   "RTN","VPR DJFSP",307 ,0)
  17682    . I ROOT= "^VPR(560. 11)" S SIZ E=$G(^VPR( 560.11,"AC NT",DOMAIN )) Q
  17683   "RTN","VPR DJFSP",308 ,0)
  17684    . I $L(RO OT) S SIZE =$P(@ROOT@ (0),U,4)
  17685   "RTN","VPR DJFSP",309 ,0)
  17686    Q $S(SIZE :SIZE,1:99 99)
  17687   "RTN","VPR DJFSP",310 ,0)
  17688    ;
  17689   "RTN","VPR DJFSP",311 ,0)
  17690   TESTPUT ;
  17691   "RTN","VPR DJFSP",312 ,0)
  17692    ;;{"serve r":"hmpTes t","localI d":"229"}
  17693   "RTN","VPR DJFSP",313 ,0)
  17694    ;;{"serve r":"hmpTes t","localI d":"229"," domains":[ "allergy", "lab","med "]}
  17695   "RTN","VPR DJFSP",314 ,0)
  17696    S U="^"
  17697   "RTN","VPR DJFSP",315 ,0)
  17698    D KILL^VP RDJFS
  17699   "RTN","VPR DJFSP",316 ,0)
  17700    N JSON S  JSON=$P($T (TESTPUT+1 ),";;",2,9 9)
  17701   "RTN","VPR DJFSP",317 ,0)
  17702    W !,$$PUT SUB("",.JS ON)
  17703   "RTN","VPR DJFSP",318 ,0)
  17704    Q
  17705   "RTN","VPR DJFSP",319 ,0)
  17706   TESTDQ ;
  17707   "RTN","VPR DJFSP",320 ,0)
  17708    D KILL^VP RDJFS
  17709   "RTN","VPR DJFSP",321 ,0)
  17710    N VPRBATC H,VPRFDFN, VPRFDOM,ZT SK
  17711   "RTN","VPR DJFSP",322 ,0)
  17712    S VPRBATC H="VPRFX~h mpTest~229 "
  17713   "RTN","VPR DJFSP",323 ,0)
  17714    S VPRFDFN =229
  17715   "RTN","VPR DJFSP",324 ,0)
  17716    S VPRFDOM (1)="aller gy",VPRFDO M(2)="lab" ,VPRFDOM(3 )="med"
  17717   "RTN","VPR DJFSP",325 ,0)
  17718    D NEWXTMP ^VPRDJFS(V PRBATCH,1, "VPR Test  Patient Ex tract")
  17719   "RTN","VPR DJFSP",326 ,0)
  17720    N I S I=0  F  S I=$O (VPRFDOM(I )) Q:'I  D  SETDOM("s tatus",VPR FDOM(I),0)
  17721   "RTN","VPR DJFSP",327 ,0)
  17722    S ZTSK=99 999,ZTQUEU ED=1
  17723   "RTN","VPR DJFSP",328 ,0)
  17724    K ^XTMP(V PRBATCH)
  17725   "RTN","VPR DJFSP",329 ,0)
  17726    S ^XTMP(V PRBATCH,0, "task",ZTS K)=""
  17727   "RTN","VPR DJFSP",330 ,0)
  17728    D DQINIT
  17729   "RTN","VPR DJFSP",331 ,0)
  17730    Q
  17731   "RTN","VPR DJFSP",332 ,0)
  17732    ;
  17733   "RTN","VPR DJFSP",333 ,0)
  17734   TESTFRSH(S ERVER,LAST UPD) ;
  17735   "RTN","VPR DJFSP",334 ,0)
  17736    N I,C,LI, FILTER,RES ULT
  17737   "RTN","VPR DJFSP",335 ,0)
  17738    S FILTER( "command") ="getPtUpd ates"
  17739   "RTN","VPR DJFSP",336 ,0)
  17740    S FILTER( "lastUpdat e")=LASTUP D
  17741   "RTN","VPR DJFSP",337 ,0)
  17742    S FILTER( "server")= SERVER
  17743   "RTN","VPR DJFSP",338 ,0)
  17744    D API^VPR DJFS(.RESU LT,.FILTER )
  17745   "RTN","VPR DJFSP",339 ,0)
  17746    S I=""
  17747   "RTN","VPR DJFSP",340 ,0)
  17748    F  S I=$O (^TMP("VPR F",$J,I))  Q:I=""  D
  17749   "RTN","VPR DJFSP",341 ,0)
  17750    .W $G(^TM P("VPRF",$ J,I))
  17751   "RTN","VPR DJFSP",342 ,0)
  17752    .S LI=I
  17753   "RTN","VPR DJFSP",343 ,0)
  17754    .S C="" F   S C=$O(^ TMP("VPRF" ,$J,I,C))  Q:C=""  W  ^TMP("VPRF ",$J,I,C)
  17755   "RTN","VPR DJFSP",344 ,0)
  17756    Q
  17757   "RTN","VPR DJFSP",345 ,0)
  17758    ;
  17759   "RTN","VPR DJFSP",346 ,0)
  17760   TESTOPD(VP RFADOM) ;
  17761   "RTN","VPR DJFSP",347 ,0)
  17762    S VPRBATC H="VPRFX~t est-1~OPD"
  17763   "RTN","VPR DJFSP",348 ,0)
  17764    K ^XTMP(V PRBATCH)
  17765   "RTN","VPR DJFSP",349 ,0)
  17766    S VPRFZTS K="123"
  17767   "RTN","VPR DJFSP",350 ,0)
  17768    S ZTQUEUE D=1
  17769   "RTN","VPR DJFSP",351 ,0)
  17770    S ^XTMP(V PRBATCH,0, "task",VPR FZTSK)=0
  17771   "RTN","VPR DJFSP",352 ,0)
  17772    D DOMOPD( VPRFADOM)
  17773   "RTN","VPR DJFSP",353 ,0)
  17774    ;
  17775   "RTN","VPR DJFST")
  17776   0^88^B4547 5446
  17777   "RTN","VPR DJFST",1,0 )
  17778   VPRDJFST ; SLC/KCM --  Tests for  extract a nd freshne ss stream
  17779   "RTN","VPR DJFST",2,0 )
  17780    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  17781   "RTN","VPR DJFST",3,0 )
  17782    ;
  17783   "RTN","VPR DJFST",4,0 )
  17784    ; Test Op erational  Synchroniz ation
  17785   "RTN","VPR DJFST",5,0 )
  17786    ;
  17787   "RTN","VPR DJFST",6,0 )
  17788   TESTOPD(NU M) ; Test  operationa l data for  server NU M
  17789   "RTN","VPR DJFST",7,0 )
  17790    Q:'NUM
  17791   "RTN","VPR DJFST",8,0 )
  17792    N SERVER
  17793   "RTN","VPR DJFST",9,0 )
  17794    S SERVER= "Test-Serv er-"_NUM
  17795   "RTN","VPR DJFST",10, 0)
  17796    D RUNOPD( SERVER)
  17797   "RTN","VPR DJFST",11, 0)
  17798    Q
  17799   "RTN","VPR DJFST",12, 0)
  17800   RUNOPD(SER VER) ; Tes t operatio nal data
  17801   "RTN","VPR DJFST",13, 0)
  17802    K ^TMP("V PRF",$J)
  17803   "RTN","VPR DJFST",14, 0)
  17804    N LASTUP, COLLECT,DO MTOT,TOTAL ,DONE,STRT ERR
  17805   "RTN","VPR DJFST",15, 0)
  17806    S LASTUP= 0,TOTAL=0, DONE=0
  17807   "RTN","VPR DJFST",16, 0)
  17808    D ADDSRVR (SERVER)
  17809   "RTN","VPR DJFST",17, 0)
  17810    D RSETSRV (SERVER)
  17811   "RTN","VPR DJFST",18, 0)
  17812    D OPDSTRT (SERVER) Q :$G(STRTER R)
  17813   "RTN","VPR DJFST",19, 0)
  17814    F  H 2 D  GETUPDS(SE RVER,.LAST UP) Q:DONE
  17815   "RTN","VPR DJFST",20, 0)
  17816    D GETUPDS (SERVER,.L ASTUP) ; o ne last ti me to clea r ^XTMP
  17817   "RTN","VPR DJFST",21, 0)
  17818    ; Write o ut the col lection co unts and d omain tota ls.
  17819   "RTN","VPR DJFST",22, 0)
  17820    ; They sh ould be th e same unl ess 1 item , which ma y be just  the wrappe r.
  17821   "RTN","VPR DJFST",23, 0)
  17822    N NM
  17823   "RTN","VPR DJFST",24, 0)
  17824    W !!!,"Co llection", ?20,"Objec ts",?30,"D omain Tota ls",!
  17825   "RTN","VPR DJFST",25, 0)
  17826    S NM="" F   S NM=$O( COLLECT(NM )) Q:NM=""   D
  17827   "RTN","VPR DJFST",26, 0)
  17828    . W !,NM, ?20,$J($G( COLLECT(NM )),7),?30, $J($G(COLL ECT(NM,"to tal")),13)
  17829   "RTN","VPR DJFST",27, 0)
  17830    W !!,"Tot al Objects : ",TOTAL
  17831   "RTN","VPR DJFST",28, 0)
  17832    K ^TMP("V PRF",$J)
  17833   "RTN","VPR DJFST",29, 0)
  17834    Q
  17835   "RTN","VPR DJFST",30, 0)
  17836   ADDSRVR(SE RVER) ; ad d a SERVER  if not th ere
  17837   "RTN","VPR DJFST",31, 0)
  17838    Q:$D(^VPR (560,"B",S ERVER))
  17839   "RTN","VPR DJFST",32, 0)
  17840    N FDA,FDA IEN,DIERR, ERR
  17841   "RTN","VPR DJFST",33, 0)
  17842    S FDA(560 ,"+1,",.01 )=SERVER
  17843   "RTN","VPR DJFST",34, 0)
  17844    D UPDATE^ DIE("","FD A","FDAIEN ","ERR")
  17845   "RTN","VPR DJFST",35, 0)
  17846    I $D(DIER R) W !,"Er ror saving  server"
  17847   "RTN","VPR DJFST",36, 0)
  17848    D CLEAN^D ILF
  17849   "RTN","VPR DJFST",37, 0)
  17850    Q
  17851   "RTN","VPR DJFST",38, 0)
  17852   RSETSRV(SE RVER) ; Re set subscr iptions fo r named SE RVER
  17853   "RTN","VPR DJFST",39, 0)
  17854    N ARGS,RS P
  17855   "RTN","VPR DJFST",40, 0)
  17856    S ARGS("c ommand")=" resetAllSu bscription s"
  17857   "RTN","VPR DJFST",41, 0)
  17858    S ARGS("s erver")=SE RVER
  17859   "RTN","VPR DJFST",42, 0)
  17860    D API^VPR DJFS(.RSP, .ARGS)
  17861   "RTN","VPR DJFST",43, 0)
  17862    W !,"Rese t",?10,@RS P@(1) ;{"a piVersion" :"1.0","re moved":"tr ue"}
  17863   "RTN","VPR DJFST",44, 0)
  17864    Q
  17865   "RTN","VPR DJFST",45, 0)
  17866   OPDSTRT(SE RVER) ; St art operat ional data  extracts  for SERVER
  17867   "RTN","VPR DJFST",46, 0)
  17868    N ARGS,RS P
  17869   "RTN","VPR DJFST",47, 0)
  17870    S ARGS("c ommand")=" startOpera tionalData Extract"
  17871   "RTN","VPR DJFST",48, 0)
  17872    S ARGS("s erver")=SE RVER
  17873   "RTN","VPR DJFST",49, 0)
  17874    D API^VPR DJFS(.RSP, .ARGS) ;SH OULD THIS  RETURN TAS K #?
  17875   "RTN","VPR DJFST",50, 0)
  17876    W !,"Star t",?10,@RS P@(1) ;{"a piVersion" :"1.0","lo cation":"/ vpr/subscr iption/Tes t-Server-1 /patient/" }
  17877   "RTN","VPR DJFST",51, 0)
  17878    I @RSP@(1 )["""error "":" S STR TERR=1
  17879   "RTN","VPR DJFST",52, 0)
  17880    Q
  17881   "RTN","VPR DJFST",53, 0)
  17882   GETUPDS(SE RVER,LASTU P) ; Get u pdates for  the named  SERVER
  17883   "RTN","VPR DJFST",54, 0)
  17884    ; expects  COLLECT,D OMTOT,TOTA L,DONE
  17885   "RTN","VPR DJFST",55, 0)
  17886    N ARGS,RS P,CNT
  17887   "RTN","VPR DJFST",56, 0)
  17888    S ARGS("c ommand")=" getPtUpdat es"
  17889   "RTN","VPR DJFST",57, 0)
  17890    S ARGS("s erver")=SE RVER
  17891   "RTN","VPR DJFST",58, 0)
  17892    S ARGS("l astUpdate" )=LASTUP
  17893   "RTN","VPR DJFST",59, 0)
  17894    S ARGS("m ax")=1000
  17895   "RTN","VPR DJFST",60, 0)
  17896    D API^VPR DJFS(.RSP, .ARGS)
  17897   "RTN","VPR DJFST",61, 0)
  17898    S LASTUP= $$GETLUPD( ),CNT=$$CN TOBJS(),TO TAL=TOTAL+ CNT
  17899   "RTN","VPR DJFST",62, 0)
  17900    W !,^TMP( "VPRF",$J, .5)
  17901   "RTN","VPR DJFST",63, 0)
  17902    W !,"Fetc h",?10,"Ob ject Count : ",$J(CNT ,7),"   La st Update:  ",LASTUP
  17903   "RTN","VPR DJFST",64, 0)
  17904    D CNTCOLL (.COLLECT, .DONE) ; c ount colle ctions
  17905   "RTN","VPR DJFST",65, 0)
  17906    D VALOBJS
  17907   "RTN","VPR DJFST",66, 0)
  17908    ;D SHOWHD RS
  17909   "RTN","VPR DJFST",67, 0)
  17910    ;D SHOWDA TA("pt-sel ect^displa ygroup^")
  17911   "RTN","VPR DJFST",68, 0)
  17912    Q
  17913   "RTN","VPR DJFST",69, 0)
  17914   CNTCOLL(CO LL,DONE) ;  add colle ction coun ts
  17915   "RTN","VPR DJFST",70, 0)
  17916    N I,NM
  17917   "RTN","VPR DJFST",71, 0)
  17918    S I=.9 F   S I=$O(^T MP("VPRF", $J,I)) Q:' I  D
  17919   "RTN","VPR DJFST",72, 0)
  17920    . S NM=$P ($P($G(^TM P("VPRF",$ J,I,.3))," ""collecti on"":""",2 ),"""")
  17921   "RTN","VPR DJFST",73, 0)
  17922    . Q:'$L(N M)
  17923   "RTN","VPR DJFST",74, 0)
  17924    . I NM="s yncStatus"  D DOMTOT( .COLL,I) S  DONE=1 Q
  17925   "RTN","VPR DJFST",75, 0)
  17926    . S COLL( NM)=$G(COL L(NM))+1
  17927   "RTN","VPR DJFST",76, 0)
  17928    Q
  17929   "RTN","VPR DJFST",77, 0)
  17930   DOMTOT(COL L,I) ; add  domain to tals to co llection a rray
  17931   "RTN","VPR DJFST",78, 0)
  17932    N JSON,OB J,ERR
  17933   "RTN","VPR DJFST",79, 0)
  17934    M JSON=^T MP("VPRF", $J,I)
  17935   "RTN","VPR DJFST",80, 0)
  17936    K JSON(.3 )
  17937   "RTN","VPR DJFST",81, 0)
  17938    D DECODE^ VPRJSON("J SON","OBJ" ,"ERR")
  17939   "RTN","VPR DJFST",82, 0)
  17940    I $D(ERR)  W !,"ERRO R:  decodi ng syncSta tus object "
  17941   "RTN","VPR DJFST",83, 0)
  17942    S NM="" F   S NM=$O( OBJ("domai nTotals",N M)) Q:NM=" "  S COLL( NM,"total" )=OBJ("dom ainTotals" ,NM)
  17943   "RTN","VPR DJFST",84, 0)
  17944    Q
  17945   "RTN","VPR DJFST",85, 0)
  17946    ;
  17947   "RTN","VPR DJFST",86, 0)
  17948    ; Test Pa tient Sync ronization
  17949   "RTN","VPR DJFST",87, 0)
  17950    ;
  17951   "RTN","VPR DJFST",88, 0)
  17952   TESTPT(NUM ) ; Test o perational  data for  server NUM
  17953   "RTN","VPR DJFST",89, 0)
  17954    Q:'NUM
  17955   "RTN","VPR DJFST",90, 0)
  17956    N SERVER
  17957   "RTN","VPR DJFST",91, 0)
  17958    S SERVER= "Test-Serv er-"_NUM
  17959   "RTN","VPR DJFST",92, 0)
  17960    D RUNPT(S ERVER)
  17961   "RTN","VPR DJFST",93, 0)
  17962    Q
  17963   "RTN","VPR DJFST",94, 0)
  17964   RUNPT(SERV ER) ; Test  operation al data
  17965   "RTN","VPR DJFST",95, 0)
  17966    K ^TMP("V PRF",$J)
  17967   "RTN","VPR DJFST",96, 0)
  17968    N LASTUPD ,COLLECT,D OMTOT,TOTA L,TOTPTS,D ONEPTS,STA RT
  17969   "RTN","VPR DJFST",97, 0)
  17970    S LASTUPD =0,TOTPTS= 0,DONEPTS= 0,START=$P ($H,",",2)
  17971   "RTN","VPR DJFST",98, 0)
  17972    D ADDSRVR (SERVER)
  17973   "RTN","VPR DJFST",99, 0)
  17974    D RSETSRV (SERVER)
  17975   "RTN","VPR DJFST",100 ,0)
  17976    D ADDPTS( SERVER,.TO TPTS)
  17977   "RTN","VPR DJFST",101 ,0)
  17978    F  H 2 D  LOADUPD(SE RVER,.LAST UPD,.DONEP TS,.TOTPTS ) Q:DONEPT S'<TOTPTS
  17979   "RTN","VPR DJFST",102 ,0)
  17980    D LOADUPD (SERVER,.L ASTUPD,.DO NEPTS,.TOT PTS) ; one  moreto cl ear ^XTMP
  17981   "RTN","VPR DJFST",103 ,0)
  17982    W !,"Elap sed Second s: ",$P($H ,",",2)-ST ART
  17983   "RTN","VPR DJFST",104 ,0)
  17984    Q
  17985   "RTN","VPR DJFST",105 ,0)
  17986   ADDPTS(SER VER,TOTPTS ) ; Add pa tients for  synchroni zation
  17987   "RTN","VPR DJFST",106 ,0)
  17988    F I=1:1 S  X=$P($T(P ATIENTS+I) ,";;",2,99 9) Q:X="zz zzz"  D
  17989   "RTN","VPR DJFST",107 ,0)
  17990    . N ARGS, RSP
  17991   "RTN","VPR DJFST",108 ,0)
  17992    . S ARGS( "command") ="putPtSub scription"
  17993   "RTN","VPR DJFST",109 ,0)
  17994    . S ARGS( "server")= SERVER
  17995   "RTN","VPR DJFST",110 ,0)
  17996    . S ARGS( "localId") =+X
  17997   "RTN","VPR DJFST",111 ,0)
  17998    . D API^V PRDJFS(.RS P,.ARGS)
  17999   "RTN","VPR DJFST",112 ,0)
  18000    . W !,$S( @RSP@(1)[" ""error"": ":"ERROR", 1:"Start") ,?10,@RSP@ (1)
  18001   "RTN","VPR DJFST",113 ,0)
  18002    . S TOTPT S=TOTPTS+1
  18003   "RTN","VPR DJFST",114 ,0)
  18004    Q
  18005   "RTN","VPR DJFST",115 ,0)
  18006   LOADUPD(SE RVER,LASTU PD,DONEPTS ,TOTPTS) ;  Load upda tes
  18007   "RTN","VPR DJFST",116 ,0)
  18008    ; expects  LASTUPD
  18009   "RTN","VPR DJFST",117 ,0)
  18010    N RSP,ARG S,ERR,CNT, LNODE
  18011   "RTN","VPR DJFST",118 ,0)
  18012    S ARGS("c ommand")=" getPtUpdat es"
  18013   "RTN","VPR DJFST",119 ,0)
  18014    S ARGS("s erver")=SE RVER
  18015   "RTN","VPR DJFST",120 ,0)
  18016    S ARGS("l astUpdate" )=LASTUPD
  18017   "RTN","VPR DJFST",121 ,0)
  18018    S ARGS("m ax")=1000
  18019   "RTN","VPR DJFST",122 ,0)
  18020    D API^VPR DJFS(.RSP, .ARGS)
  18021   "RTN","VPR DJFST",123 ,0)
  18022    S DONEPTS =DONEPTS+$ $SCAN4STS
  18023   "RTN","VPR DJFST",124 ,0)
  18024    S LASTUPD =$$GETLUPD
  18025   "RTN","VPR DJFST",125 ,0)
  18026    S CNT=$$C NTOBJS
  18027   "RTN","VPR DJFST",126 ,0)
  18028    D VALOBJS
  18029   "RTN","VPR DJFST",127 ,0)
  18030    W !,^TMP( "VPRF",$J, .5)
  18031   "RTN","VPR DJFST",128 ,0)
  18032    W !,"last Update: ", LASTUPD,"   items: ", CNT,?50,"l oaded: ",D ONEPTS_"/" _TOTPTS Q
  18033   "RTN","VPR DJFST",129 ,0)
  18034    ;
  18035   "RTN","VPR DJFST",130 ,0)
  18036    ; Common  functions
  18037   "RTN","VPR DJFST",131 ,0)
  18038    ;
  18039   "RTN","VPR DJFST",132 ,0)
  18040   SCAN4STS()  ; Scan he aders for  syncDone o bjects
  18041   "RTN","VPR DJFST",133 ,0)
  18042    N I,STSCN T
  18043   "RTN","VPR DJFST",134 ,0)
  18044    S STSCNT= 0,I=0 F  S  I=$O(^TMP ("VPRF",$J ,I)) Q:'I   D
  18045   "RTN","VPR DJFST",135 ,0)
  18046    . I $G(^T MP("VPRF", $J,I,.3))[ "syncStatu s" S STSCN T=STSCNT+1
  18047   "RTN","VPR DJFST",136 ,0)
  18048    Q STSCNT
  18049   "RTN","VPR DJFST",137 ,0)
  18050    ;
  18051   "RTN","VPR DJFST",138 ,0)
  18052   GETLUPD()  ; Return l ast update  value
  18053   "RTN","VPR DJFST",139 ,0)
  18054    N X
  18055   "RTN","VPR DJFST",140 ,0)
  18056    S X=^TMP( "VPRF",$J, .5),X=$P(X ,"""lastUp date"":""" ,2),X=$P(X ,""",")
  18057   "RTN","VPR DJFST",141 ,0)
  18058    Q X
  18059   "RTN","VPR DJFST",142 ,0)
  18060    ;
  18061   "RTN","VPR DJFST",143 ,0)
  18062   SHOWHDRS ;  Show obje ct header  info
  18063   "RTN","VPR DJFST",144 ,0)
  18064    N I,X
  18065   "RTN","VPR DJFST",145 ,0)
  18066    S I=0 F   S I=$O(^TM P("VPRF",$ J,I)) Q:'I   D
  18067   "RTN","VPR DJFST",146 ,0)
  18068    . S X=$G( ^TMP("VPRF ",$J,I,.3) )
  18069   "RTN","VPR DJFST",147 ,0)
  18070    . Q:'$L(X )
  18071   "RTN","VPR DJFST",148 ,0)
  18072    . W !,"Hd r: ",X
  18073   "RTN","VPR DJFST",149 ,0)
  18074    Q
  18075   "RTN","VPR DJFST",150 ,0)
  18076   SHOWDATA(C OLL) ; Sho w the JSON  objects b eing retur ned
  18077   "RTN","VPR DJFST",151 ,0)
  18078    N I,X
  18079   "RTN","VPR DJFST",152 ,0)
  18080    S I=.5 F   S I=$O(^T MP("VPRF", $J,I)) Q:' I  D
  18081   "RTN","VPR DJFST",153 ,0)
  18082    . S X=$G( ^TMP("VPRF ",$J,I,.3) )
  18083   "RTN","VPR DJFST",154 ,0)
  18084    . S X=$P( $P(X,"coll ection"":" "",2),"""" )
  18085   "RTN","VPR DJFST",155 ,0)
  18086    . Q:'$L(X )  Q:'(COL L[X)
  18087   "RTN","VPR DJFST",156 ,0)
  18088    . W !,"Hd r:",$G(^TM P("VPRF",$ J,I,.3))
  18089   "RTN","VPR DJFST",157 ,0)
  18090    . W !,"Dt a:",$G(^TM P("VPRF",$ J,I,1))
  18091   "RTN","VPR DJFST",158 ,0)
  18092    Q
  18093   "RTN","VPR DJFST",159 ,0)
  18094   VALOBJS ;  Validate o bjects
  18095   "RTN","VPR DJFST",160 ,0)
  18096    N I,HDR
  18097   "RTN","VPR DJFST",161 ,0)
  18098    S I=.5 F   S I=$O(^T MP("VPRF", $J,I)) Q:' I  D
  18099   "RTN","VPR DJFST",162 ,0)
  18100    . S HDR=$ G(^TMP("VP RF",$J,I,. 3))
  18101   "RTN","VPR DJFST",163 ,0)
  18102    . Q:'$L(H DR)
  18103   "RTN","VPR DJFST",164 ,0)
  18104    . ;W !,"H dr: ",HDR
  18105   "RTN","VPR DJFST",165 ,0)
  18106    . N OBJ,J SON,LAST,E RROR
  18107   "RTN","VPR DJFST",166 ,0)
  18108    . M JSON= ^TMP("VPRF ",$J,I)
  18109   "RTN","VPR DJFST",167 ,0)
  18110    . I $E(JS ON(.3))="} " S JSON(. 3)=$E(JSON (.3),3,$L( JSON(.3)))
  18111   "RTN","VPR DJFST",168 ,0)
  18112    . S LAST= $O(JSON("" ),-1),LAST =LAST+1 S  JSON(LAST) ="}"
  18113   "RTN","VPR DJFST",169 ,0)
  18114    . D DECOD E^VPRJSON( "JSON","OB J","ERROR" )
  18115   "RTN","VPR DJFST",170 ,0)
  18116    . ;W:'$D( ERROR) " o k"
  18117   "RTN","VPR DJFST",171 ,0)
  18118    . I $D(ER ROR) W !,"   >>> ERRO R:  ",HDR
  18119   "RTN","VPR DJFST",172 ,0)
  18120    Q
  18121   "RTN","VPR DJFST",173 ,0)
  18122   CNTOBJS()  ; Return c ount of ob jects retu rned
  18123   "RTN","VPR DJFST",174 ,0)
  18124    N I,C
  18125   "RTN","VPR DJFST",175 ,0)
  18126    S C=0
  18127   "RTN","VPR DJFST",176 ,0)
  18128    S I=.9 ;  skip .5 he ader node
  18129   "RTN","VPR DJFST",177 ,0)
  18130    F  S I=$O (^TMP("VPR F",$J,I))  Q:'I  I $L ($G(^TMP(" VPRF",$J,I ,1))) S C= C+1
  18131   "RTN","VPR DJFST",178 ,0)
  18132    Q C
  18133   "RTN","VPR DJFST",179 ,0)
  18134    ;
  18135   "RTN","VPR DJFST",180 ,0)
  18136   TOTALS ;
  18137   "RTN","VPR DJFST",181 ,0)
  18138    N P,T
  18139   "RTN","VPR DJFST",182 ,0)
  18140    S T=0
  18141   "RTN","VPR DJFST",183 ,0)
  18142    S P=0 F   S P=$O(^XT MP("VPRFP" ,P)) Q:'P   S T=T+^XT MP("VPRFP" ,P,"hmpTes t","total" )
  18143   "RTN","VPR DJFST",184 ,0)
  18144    W !,"TOTA L: ",T
  18145   "RTN","VPR DJFST",185 ,0)
  18146    Q
  18147   "RTN","VPR DJFST",186 ,0)
  18148   GETFEW ;
  18149   "RTN","VPR DJFST",187 ,0)
  18150    S ARGS("c ommand")=" getPtUpdat es"
  18151   "RTN","VPR DJFST",188 ,0)
  18152    S ARGS("s erver")="h mpTest"
  18153   "RTN","VPR DJFST",189 ,0)
  18154    S ARGS("l astUpdate" )="3140115 -251"
  18155   "RTN","VPR DJFST",190 ,0)
  18156    S ARGS("m ax")=10
  18157   "RTN","VPR DJFST",191 ,0)
  18158    D API^VPR DJFS(.RSP, .ARGS)
  18159   "RTN","VPR DJFST",192 ,0)
  18160    Q
  18161   "RTN","VPR DJFST",193 ,0)
  18162   PATIENTS ;  list of p atients
  18163   "RTN","VPR DJFST",194 ,0)
  18164    ;;25      AVIVAPATIE NT,TWENTYT HREE
  18165   "RTN","VPR DJFST",195 ,0)
  18166    ;;100848  AVIVAPATIE NT,EIGHT
  18167   "RTN","VPR DJFST",196 ,0)
  18168    ;;100851  AVIVAPATIE NT,ELEVEN
  18169   "RTN","VPR DJFST",197 ,0)
  18170    ;;100846  AVIVAPATIE NT,FIVE
  18171   "RTN","VPR DJFST",198 ,0)
  18172    ;;100845  AVIVAPATIE NT,FOUR
  18173   "RTN","VPR DJFST",199 ,0)
  18174    ;;100849  AVIVAPATIE NT,NINE
  18175   "RTN","VPR DJFST",200 ,0)
  18176    ;;100842  AVIVAPATIE NT,ONE
  18177   "RTN","VPR DJFST",201 ,0)
  18178    ;;100841  AVIVAPATIE NT,SEVEN
  18179   "RTN","VPR DJFST",202 ,0)
  18180    ;;100847  AVIVAPATIE NT,SIX
  18181   "RTN","VPR DJFST",203 ,0)
  18182    ;;100850  AVIVAPATIE NT,TEN
  18183   "RTN","VPR DJFST",204 ,0)
  18184    ;;8       AVIVAPATIE NT,THIRTY
  18185   "RTN","VPR DJFST",205 ,0)
  18186    ;;100844  AVIVAPATIE NT,THREE
  18187   "RTN","VPR DJFST",206 ,0)
  18188    ;;100852  AVIVAPATIE NT,TWELVE
  18189   "RTN","VPR DJFST",207 ,0)
  18190    ;;3       AVIVAPATIE NT,TWENTYE IGHT
  18191   "RTN","VPR DJFST",208 ,0)
  18192    ;;231     AVIVAPATIE NT,TWENTYF IVE
  18193   "RTN","VPR DJFST",209 ,0)
  18194    ;;229     AVIVAPATIE NT,TWENTYF OUR
  18195   "RTN","VPR DJFST",210 ,0)
  18196    ;;217     AVIVAPATIE NT,TWENTYN INE
  18197   "RTN","VPR DJFST",211 ,0)
  18198    ;;237     AVIVAPATIE NT,TWENTYO NE
  18199   "RTN","VPR DJFST",212 ,0)
  18200    ;;253     AVIVAPATIE NT,TWENTYS EVEN
  18201   "RTN","VPR DJFST",213 ,0)
  18202    ;;418     AVIVAPATIE NT,TWENTYS IX
  18203   "RTN","VPR DJFST",214 ,0)
  18204    ;;205     AVIVAPATIE NT,TWENTYT WO
  18205   "RTN","VPR DJFST",215 ,0)
  18206    ;;100843  AVIVAPATIE NT,TWO
  18207   "RTN","VPR DJFST",216 ,0)
  18208    ;;zzzzz
  18209   "RTN","VPR DJX")
  18210   0^52^B3616 9855
  18211   "RTN","VPR DJX",1,0)
  18212   VPRDJX ;SL C/MKB -- N ew data up date ; 11/ 5/13 7:02p m
  18213   "RTN","VPR DJX",2,0)
  18214    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  18215   "RTN","VPR DJX",3,0)
  18216    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  18217   "RTN","VPR DJX",4,0)
  18218    ;
  18219   "RTN","VPR DJX",5,0)
  18220    ; Externa l Referenc es           DBIA#
  18221   "RTN","VPR DJX",6,0)
  18222    ; ------- ---------- --           -----
  18223   "RTN","VPR DJX",7,0)
  18224    ; ^DPT                            10035
  18225   "RTN","VPR DJX",8,0)
  18226    ; MPIF001                          2701
  18227   "RTN","VPR DJX",9,0)
  18228    ; XLFSTR                          10104
  18229   "RTN","VPR DJX",10,0)
  18230    ;
  18231   "RTN","VPR DJX",11,0)
  18232   EN(LAST,MA X) ; -- ge t data fro m ^XTMP("V PR-<date>" ,n)
  18233   "RTN","VPR DJX",12,0)
  18234    ; Expects  VPR=$NA(^ TMP("VPR", $J))
  18235   "RTN","VPR DJX",13,0)
  18236    ;
  18237   "RTN","VPR DJX",14,0)
  18238    N SYS,X,Y ,VPRTOTL,D FN,PATCNT, ICN,DOMCNT ,TYPE,RTN, VPRLASTI,V PRID,DATA, DELETE,UID ,CNT,TSTAR T,TSTOP
  18239   "RTN","VPR DJX",15,0)
  18240    S TSTART= $$NOW^XLFD T()
  18241   "RTN","VPR DJX",16,0)
  18242    S LAST=$G (LAST),SYS =$G(FILTER ("systemID ")) Q:SYS= ""
  18243   "RTN","VPR DJX",17,0)
  18244    S MAX=$G( MAX,999)
  18245   "RTN","VPR DJX",18,0)
  18246    D GETLIST (LAST,SYS, MAX)
  18247   "RTN","VPR DJX",19,0)
  18248    ;
  18249   "RTN","VPR DJX",20,0)
  18250    S (DFN,PA TCNT,VPRTO TL)=0 F  S  DFN=$O(^T MP("VPRX", $J,DFN)) Q :DFN<1  D
  18251   "RTN","VPR DJX",21,0)
  18252    . K ^TMP( $J,"VPR ER ROR")
  18253   "RTN","VPR DJX",22,0)
  18254    . S PATCN T=PATCNT+1 ,ICN=+$$GE TICN^MPIF0 01(DFN),ER RPAT=DFN
  18255   "RTN","VPR DJX",23,0)
  18256    . S DOMCN T=0 K DATA ,DELETE
  18257   "RTN","VPR DJX",24,0)
  18258    . S TYPE= "" F  S TY PE=$O(^TMP ("VPRX",$J ,DFN,TYPE) ) Q:TYPE=" "  D
  18259   "RTN","VPR DJX",25,0)
  18260    .. S RTN= $$TAG^VPRD J(TYPE)_"^ VPRDJ0" Q: '$L($T(@RT N))
  18261   "RTN","VPR DJX",26,0)
  18262    .. S DOMC NT=DOMCNT+ 1
  18263   "RTN","VPR DJX",27,0)
  18264    .. ;
  18265   "RTN","VPR DJX",28,0)
  18266    .. N VPR  S VPR=$NA( ^TMP("VPR" ,$J,PATCNT ,DOMCNT)), VPRI=0,VPR ID=""
  18267   "RTN","VPR DJX",29,0)
  18268    .. F  S V PRID=$O(^T MP("VPRX", $J,DFN,TYP E,VPRID))  Q:VPRID=""   S X=$G(^ (VPRID)) D
  18269   "RTN","VPR DJX",30,0)
  18270    ... N $ES ,$ET,ERRPA T,ERRMSG
  18271   "RTN","VPR DJX",31,0)
  18272    ... S $ET ="D ERRHDL R^VPRDERRH ",ERRPAT=D FN
  18273   "RTN","VPR DJX",32,0)
  18274    ... S ERR MSG="A pro blem occur red when t rying to r efresh pat ient data  from an AP I."
  18275   "RTN","VPR DJX",33,0)
  18276    ... ;
  18277   "RTN","VPR DJX",34,0)
  18278    ... I X=" @" D DELET E(TYPE,DFN ,VPRID) Q
  18279   "RTN","VPR DJX",35,0)
  18280    ... S VPR LASTI=VPRI  D @RTN    ;creates @ VPR@(VPRI+ 1)
  18281   "RTN","VPR DJX",36,0)
  18282    ... ;
  18283   "RTN","VPR DJX",37,0)
  18284    ... ; if  no new ite m, assume  the record  has been  deleted
  18285   "RTN","VPR DJX",38,0)
  18286    ... I VPR I'>VPRLAST I D DELETE (TYPE,DFN, VPRID) Q
  18287   "RTN","VPR DJX",39,0)
  18288    ... S VPR TOTL=VPRTO TL+1,DATA= 1
  18289   "RTN","VPR DJX",40,0)
  18290    .. I 'VPR I S DOMCNT =DOMCNT-1  Q   ;no da ta, or err or
  18291   "RTN","VPR DJX",41,0)
  18292    .. ;
  18293   "RTN","VPR DJX",42,0)
  18294    .. S:DOMC NT>1 @VPR@ (.3)=","
  18295   "RTN","VPR DJX",43,0)
  18296    .. S @VPR @(.5)="{"" domainName "":"""_TYP E_""",""to tal"":"_VP RI_",""ite ms"":["
  18297   "RTN","VPR DJX",44,0)
  18298    .. S VPRI =VPRI+1,@V PR@(VPRI)= "]}"
  18299   "RTN","VPR DJX",45,0)
  18300    . ;
  18301   "RTN","VPR DJX",46,0)
  18302   A . ; VPR= $NA(^TMP(" VPR",$J))  again
  18303   "RTN","VPR DJX",47,0)
  18304    . S:PATCN T>1 @VPR@( PATCNT,.3) =","
  18305   "RTN","VPR DJX",48,0)
  18306    . S @VPR@ (PATCNT,.5 )="{""pati entDfn"":" _DFN_",""p atientIcn" ":"""_ICN_ """"
  18307   "RTN","VPR DJX",49,0)
  18308    . I DOMCN T D
  18309   "RTN","VPR DJX",50,0)
  18310    .. S @VPR @(PATCNT,. 6)=",""dom ains"":["
  18311   "RTN","VPR DJX",51,0)
  18312    .. S DOMC NT=DOMCNT+ 1,@VPR@(PA TCNT,DOMCN T)="]"
  18313   "RTN","VPR DJX",52,0)
  18314    . ;
  18315   "RTN","VPR DJX",53,0)
  18316    . I $D(DE LETE) D
  18317   "RTN","VPR DJX",54,0)
  18318    .. S DOMC NT=DOMCNT+ 1,@VPR@(PA TCNT,DOMCN T,.5)=","" deletes"": ["
  18319   "RTN","VPR DJX",55,0)
  18320    .. S VPRI =0,UID=""  F  S UID=$ O(DELETE(U ID)) Q:UID =""  D
  18321   "RTN","VPR DJX",56,0)
  18322    ... S TYP E=DELETE(U ID),VPRI=V PRI+1
  18323   "RTN","VPR DJX",57,0)
  18324    ... S:VPR I>1 @VPR@( PATCNT,DOM CNT,VPRI,. 3)=","
  18325   "RTN","VPR DJX",58,0)
  18326    ... S @VP R@(PATCNT, DOMCNT,VPR I,1)="{""u id"":"""_U ID_""",""d omainName" ":"""_TYPE _"""}"
  18327   "RTN","VPR DJX",59,0)
  18328    .. S VPRI =VPRI+1,@V PR@(PATCNT ,DOMCNT,VP RI)="]"
  18329   "RTN","VPR DJX",60,0)
  18330    . ;
  18331   "RTN","VPR DJX",61,0)
  18332    . I $D(^T MP($J,"VPR  ERROR"))  D
  18333   "RTN","VPR DJX",62,0)
  18334    .. N ERRO R D BUILDE RR^VPRDJ(. ERROR)
  18335   "RTN","VPR DJX",63,0)
  18336    .. S DOMC NT=DOMCNT+ 1,@VPR@(PA TCNT,DOMCN T,.3)=","
  18337   "RTN","VPR DJX",64,0)
  18338    .. M @VPR @(PATCNT,D OMCNT)=ERR OR
  18339   "RTN","VPR DJX",65,0)
  18340    .. K ^TMP ($J,"VPR E RROR")
  18341   "RTN","VPR DJX",66,0)
  18342    . ;
  18343   "RTN","VPR DJX",67,0)
  18344    . S DOMCN T=DOMCNT+1 ,@VPR@(PAT CNT,DOMCNT )="}"
  18345   "RTN","VPR DJX",68,0)
  18346    ;
  18347   "RTN","VPR DJX",69,0)
  18348    S Y=$G(^T MP("VPRX", $J,0)) S:Y ="" Y=LAST
  18349   "RTN","VPR DJX",70,0)
  18350    S T=$$NOW ^XLFDT()
  18351   "RTN","VPR DJX",71,0)
  18352    S @VPR@(. 5)="{""api Version"": ""1.01""," "data"":{" "lastUpdat e"":"""_Y_ """,""star tDateTime" ":"""_TSTA RT_""",""t otalPatien ts"":"_PAT CNT
  18353   "RTN","VPR DJX",72,0)
  18354    S:PATCNT  @VPR@(.6)= ",""patien ts"":[",PA TCNT=PATCN T+1,@VPR@( PATCNT)="] "
  18355   "RTN","VPR DJX",73,0)
  18356    ;
  18357   "RTN","VPR DJX",74,0)
  18358   B ;
  18359   "RTN","VPR DJX",75,0)
  18360    I $D(^TMP ("VPRX",$J ,"OP")) D          ;o perational  data
  18361   "RTN","VPR DJX",76,0)
  18362    . S (VPRT OTL,DOMCNT )=0,PATCNT =PATCNT+1  K DATA,DEL ETE
  18363   "RTN","VPR DJX",77,0)
  18364    . S TYPE= "" F  S TY PE=$O(^TMP ("VPRX",$J ,"OP",TYPE )) Q:TYPE= ""  D
  18365   "RTN","VPR DJX",78,0)
  18366    .. S RTN= $$TAG^VPRE F(TYPE)_"^ VPREF" Q:' $L($T(@RTN ))
  18367   "RTN","VPR DJX",79,0)
  18368    .. S DOMC NT=DOMCNT+ 1,DFN=""
  18369   "RTN","VPR DJX",80,0)
  18370    .. ;
  18371   "RTN","VPR DJX",81,0)
  18372    .. N VPR  S VPR=$NA( ^TMP("VPR" ,$J,PATCNT ,DOMCNT)), VPRI=0,VPR ID=""
  18373   "RTN","VPR DJX",82,0)
  18374    .. F  S V PRID=$O(^T MP("VPRX", $J,"OP",TY PE,VPRID))  Q:VPRID=" "  S X=$G( ^(VPRID))  D
  18375   "RTN","VPR DJX",83,0)
  18376    ... I X=" @" D DELET E(TYPE,DFN ,VPRID) Q
  18377   "RTN","VPR DJX",84,0)
  18378    ... S VPR LASTI=VPRI  D @RTN            ;c reates @VP R@(VPRI+1)
  18379   "RTN","VPR DJX",85,0)
  18380    ... ; if  no new ite m, assume  the record  has been  deleted
  18381   "RTN","VPR DJX",86,0)
  18382    ... I VPR I'>VPRLAST I D DELETE (TYPE,DFN, VPRID) Q
  18383   "RTN","VPR DJX",87,0)
  18384    ... S VPR TOTL=VPRTO TL+1,DATA= 1
  18385   "RTN","VPR DJX",88,0)
  18386    .. I 'VPR I S DOMCNT =DOMCNT-1  Q       ;n o data, or  error
  18387   "RTN","VPR DJX",89,0)
  18388    .. ;
  18389   "RTN","VPR DJX",90,0)
  18390    .. S:DOMC NT>1 @VPR@ (.3)=","
  18391   "RTN","VPR DJX",91,0)
  18392    .. S @VPR @(.5)="{"" domainName "":"""_TYP E_""",""to tal"":"_VP RI_",""ite ms"":["
  18393   "RTN","VPR DJX",92,0)
  18394    .. S VPRI =VPRI+1,@V PR@(VPRI)= "]}"
  18395   "RTN","VPR DJX",93,0)
  18396    . ;
  18397   "RTN","VPR DJX",94,0)
  18398   C . ; VPR= $NA(^TMP(" VPR",$J))  again
  18399   "RTN","VPR DJX",95,0)
  18400    . I 'DOMC NT,'$D(DEL ETE) Q  ;n o data, or  error
  18401   "RTN","VPR DJX",96,0)
  18402    . S @VPR@ (PATCNT,.5 )=",""oper ational"": {"
  18403   "RTN","VPR DJX",97,0)
  18404    . I DOMCN T D
  18405   "RTN","VPR DJX",98,0)
  18406    .. S @VPR @(PATCNT,. 6)="""doma ins"":["
  18407   "RTN","VPR DJX",99,0)
  18408    .. S DOMC NT=DOMCNT+ 1 S @VPR@( PATCNT,DOM CNT)="]"
  18409   "RTN","VPR DJX",100,0 )
  18410    . ;
  18411   "RTN","VPR DJX",101,0 )
  18412    . I $D(DE LETE) D
  18413   "RTN","VPR DJX",102,0 )
  18414    .. S DOMC NT=DOMCNT+ 1 S:DOMCNT >1 @VPR@(P ATCNT,DOMC NT,.3)=","
  18415   "RTN","VPR DJX",103,0 )
  18416    .. S @VPR @(PATCNT,D OMCNT,.5)= """deletes "":["
  18417   "RTN","VPR DJX",104,0 )
  18418    .. S VPRI =0,UID=""  F  S UID=$ O(DELETE(U ID)) Q:UID =""  D
  18419   "RTN","VPR DJX",105,0 )
  18420    ... S TYP E=DELETE(U ID),VPRI=V PRI+1
  18421   "RTN","VPR DJX",106,0 )
  18422    ... S:VPR I>1 @VPR@( PATCNT,DOM CNT,VPRI,. 3)=","
  18423   "RTN","VPR DJX",107,0 )
  18424    ... S @VP R@(PATCNT, DOMCNT,VPR I,1)="{""u id"":"""_U ID_""",""d omainName" ":"""_TYPE _"""}"
  18425   "RTN","VPR DJX",108,0 )
  18426    .. S VPRI =VPRI+1,@V PR@(PATCNT ,DOMCNT,VP RI)="]"
  18427   "RTN","VPR DJX",109,0 )
  18428    . ;
  18429   "RTN","VPR DJX",110,0 )
  18430    . S DOMCN T=DOMCNT+1 ,@VPR@(PAT CNT,DOMCNT )="}"
  18431   "RTN","VPR DJX",111,0 )
  18432    ; 
  18433   "RTN","VPR DJX",112,0 )
  18434    S TSTOP=$ $NOW^XLFDT ()
  18435   "RTN","VPR DJX",113,0 )
  18436    S PATCNT= PATCNT+1,@ VPR@(PATCN T)=",""end DateTime"" :"""_TSTOP _"""}}" ;c lose JSON
  18437   "RTN","VPR DJX",114,0 )
  18438    K ^TMP("V PRX",$J),^ TMP("VPRTE XT",$J)
  18439   "RTN","VPR DJX",115,0 )
  18440    Q
  18441   "RTN","VPR DJX",116,0 )
  18442    ;
  18443   "RTN","VPR DJX",117,0 )
  18444   DELETE(NAM E,DFN,ID)  ; -- set D ELETE node s
  18445   "RTN","VPR DJX",118,0 )
  18446    N UID
  18447   "RTN","VPR DJX",119,0 )
  18448    S UID=$$S ETUID^VPRU TILS(NAME, DFN,ID)
  18449   "RTN","VPR DJX",120,0 )
  18450    S DELETE( UID)=NAME
  18451   "RTN","VPR DJX",121,0 )
  18452    Q
  18453   "RTN","VPR DJX",122,0 )
  18454    ;
  18455   "RTN","VPR DJX",123,0 )
  18456   GETLIST(LA ST,SYS,MAX ) ; -- bui ld list of  updates f or client
  18457   "RTN","VPR DJX",124,0 )
  18458    ; Returns  ^TMP("VPR X",$J,0) =  last DATE :SEQ inclu ded
  18459   "RTN","VPR DJX",125,0 )
  18460    ;          ^TMP("VPR X",$J,DFN, TYPE,ID)=A CT
  18461   "RTN","VPR DJX",126,0 )
  18462    N DATE,SE Q,DA,END,I DX,X0,DFN, TYPE,ID,AC T,D,N,CNT
  18463   "RTN","VPR DJX",127,0 )
  18464    K ^TMP("V PRX",$J)
  18465   "RTN","VPR DJX",128,0 )
  18466    S DATE=+L AST,SEQ=+$ P(LAST,":" ,2),CNT=0
  18467   "RTN","VPR DJX",129,0 )
  18468    S DA=$$FI ND^VPRPATS (SYS) Q:'D A
  18469   "RTN","VPR DJX",130,0 )
  18470    ;
  18471   "RTN","VPR DJX",131,0 )
  18472    ; generat e list ID,  and end p oint
  18473   "RTN","VPR DJX",132,0 )
  18474    S D=DT,N= +$O(^XTMP( "VPR-"_DT, "A"),-1)        ;last  entry, as  of now
  18475   "RTN","VPR DJX",133,0 )
  18476    I DATE=DT ,SEQ=N S ^ TMP("VPRX" ,$J,0)=LAS T Q  ;no n ew items
  18477   "RTN","VPR DJX",134,0 )
  18478    ;
  18479   "RTN","VPR DJX",135,0 )
  18480    S IDX=$NA (^XTMP("VP R-"_DATE,S EQ)),END=N      ;init  loop wher e left off
  18481   "RTN","VPR DJX",136,0 )
  18482    F  S IDX= $Q(@IDX) Q :$$DONE  D   Q:CNT'<M AX
  18483   "RTN","VPR DJX",137,0 )
  18484    . S D=+$P (IDX,"-",2 ),N=+$P(ID X,",",2)
  18485   "RTN","VPR DJX",138,0 )
  18486    . S X0=@I DX,DFN=$P( X0,U) S:DF N="" DFN=" OP"
  18487   "RTN","VPR DJX",139,0 )
  18488    . I DFN,' $D(^VPR(56 0,"ADFN",D FN,DA)) Q
  18489   "RTN","VPR DJX",140,0 )
  18490    . S TYPE= $P(X0,U,2) ,ID=$P(X0, U,3),ACT=$ P(X0,U,4)
  18491   "RTN","VPR DJX",141,0 )
  18492    . I TYPE= ""!(ID="")  Q  ;error
  18493   "RTN","VPR DJX",142,0 )
  18494    . I TYPE= "ROSTER",' $D(^VPR(56 0,"AROS",I D,DA)) Q
  18495   "RTN","VPR DJX",143,0 )
  18496    . S:'$D(^ TMP("VPRX" ,$J,DFN,TY PE,ID)) CN T=CNT+1
  18497   "RTN","VPR DJX",144,0 )
  18498    . S ^TMP( "VPRX",$J, DFN,TYPE,I D)=ACT
  18499   "RTN","VPR DJX",145,0 )
  18500    S ^TMP("V PRX",$J,0) =D_":"_N                   ;fina l date:seq
  18501   "RTN","VPR DJX",146,0 )
  18502    Q
  18503   "RTN","VPR DJX",147,0 )
  18504    ;
  18505   "RTN","VPR DJX",148,0 )
  18506   DONE() ; - - Return 1  or 0, if  loop has f inished
  18507   "RTN","VPR DJX",149,0 )
  18508    I IDX'?1" ^XTMP(""VP R-"7N.E  Q  1       ; end of ^XT MP("VPR")
  18509   "RTN","VPR DJX",150,0 )
  18510    N D,N S D =+$P(IDX," -",2),N=+$ P(IDX,",", 2)
  18511   "RTN","VPR DJX",151,0 )
  18512    ; check V PR-DATE su bscript
  18513   "RTN","VPR DJX",152,0 )
  18514    I D<DT Q  0                              ; prior day:  keep goin g
  18515   "RTN","VPR DJX",153,0 )
  18516    I D>DT Q  1                              ; next day:   stop loop
  18517   "RTN","VPR DJX",154,0 )
  18518    ; D=DT: c heck seque nce# subsc ript
  18519   "RTN","VPR DJX",155,0 )
  18520    I N>END Q  1
  18521   "RTN","VPR DJX",156,0 )
  18522    Q 0
  18523   "RTN","VPR DX")
  18524   1^43
  18525   "RTN","VPR EASU")
  18526   0^53^B5980 1408
  18527   "RTN","VPR EASU",1,0)
  18528   VPREASU ;S LC/GRR --  Serve Vist A referenc e data as  JSON via R PC ; 10/18 /12 6:26pm
  18529   "RTN","VPR EASU",2,0)
  18530    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  18531   "RTN","VPR EASU",3,0)
  18532    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  18533   "RTN","VPR EASU",4,0)
  18534    ;
  18535   "RTN","VPR EASU",5,0)
  18536   CLASS ; --  USR Class  file #893 0
  18537   "RTN","VPR EASU",6,0)
  18538    N PRV S P RV=+$G(VPR LAST)
  18539   "RTN","VPR EASU",7,0)
  18540    S VPRCNT= $$TOTAL^VP REF("^USR( 8930)")
  18541   "RTN","VPR EASU",8,0)
  18542    I PRV=0 S  PRV=.9
  18543   "RTN","VPR EASU",9,0)
  18544    I $L(VPRI D) D CLS1( VPRID) Q
  18545   "RTN","VPR EASU",10,0 )
  18546    F  S PRV= $O(^USR(89 30,PRV)) Q :PRV'>0  D  CLS1(PRV)  I VPRMAX, VPRI'<VPRM AX Q
  18547   "RTN","VPR EASU",11,0 )
  18548    I PRV'>0  S VPRFINI= 1
  18549   "RTN","VPR EASU",12,0 )
  18550    Q
  18551   "RTN","VPR EASU",13,0 )
  18552    ;
  18553   "RTN","VPR EASU",14,0 )
  18554   CLS1(IEN)  ;
  18555   "RTN","VPR EASU",15,0 )
  18556    N $ES,$ET ,ERRMSG
  18557   "RTN","VPR EASU",16,0 )
  18558    S ERRMSG= $$ERRMSG^V PREF("User  Class",IE N)
  18559   "RTN","VPR EASU",17,0 )
  18560    S $ET="D  ERRHDLR^VP RDERRH"
  18561   "RTN","VPR EASU",18,0 )
  18562    N VPRV,FL DS,X,Y,INR EC
  18563   "RTN","VPR EASU",19,0 )
  18564    K VPRV S  FLDS=".01: .05;1*"
  18565   "RTN","VPR EASU",20,0 )
  18566    D GETS^DI Q(8930,IEN _",",FLDS, "IEN","VPR V")
  18567   "RTN","VPR EASU",21,0 )
  18568    S Y=$NA(V PRV(8930,I EN_","))
  18569   "RTN","VPR EASU",22,0 )
  18570    S INREC(" name")=$G( @Y@(.01,"E "))
  18571   "RTN","VPR EASU",23,0 )
  18572    S INREC(" localId")= IEN,INREC( "uid")=$$S ETUID^VPRU TILS("asu- class",,IE N)
  18573   "RTN","VPR EASU",24,0 )
  18574    S INREC(" abbreviati on")=$G(@Y @(.02,"E") ),INREC("a ctive")=$S ($G(@Y@(.0 3,"I"))=1: "true",1:" false")
  18575   "RTN","VPR EASU",25,0 )
  18576    S INREC(" displayNam e")=$G(@Y@ (.04,"E"))
  18577   "RTN","VPR EASU",26,0 )
  18578    I $D(VPRV ("8930.01" )) D
  18579   "RTN","VPR EASU",27,0 )
  18580    . N IEN2, ID,CNT
  18581   "RTN","VPR EASU",28,0 )
  18582    . S IEN2= "",CNT=0
  18583   "RTN","VPR EASU",29,0 )
  18584    . F  S IE N2=$O(VPRV (8930.01,I EN2)) Q:IE N2=""  D
  18585   "RTN","VPR EASU",30,0 )
  18586    . . S CNT =CNT+1,INR EC("subCla ss",CNT,"n ame")=VPRV ("8930.01" ,IEN2,".01 ","E")
  18587   "RTN","VPR EASU",31,0 )
  18588    . . S ID= VPRV(8930. 01,IEN2,.0 1,"I"),INR EC("subCla ss",CNT,"u id")=$$SET UID^VPRUTI LS("asu-cl ass",,ID)
  18589   "RTN","VPR EASU",32,0 )
  18590    D ADD^VPR EF("INREC" ) S VPRLAS T=IEN
  18591   "RTN","VPR EASU",33,0 )
  18592    Q
  18593   "RTN","VPR EASU",34,0 )
  18594    ;
  18595   "RTN","VPR EASU",35,0 )
  18596   RULE ; --  USR Author ization/Su bscription  file #893 0.1
  18597   "RTN","VPR EASU",36,0 )
  18598    N PRV S P RV=+$G(VPR LAST)
  18599   "RTN","VPR EASU",37,0 )
  18600    S VPRCNT= $$TOTAL^VP REF("^USR( 8930.1)")
  18601   "RTN","VPR EASU",38,0 )
  18602    I PRV=0 S  PRV=.9
  18603   "RTN","VPR EASU",39,0 )
  18604    I $L(VPRI D) D RULE1 (VPRID) Q
  18605   "RTN","VPR EASU",40,0 )
  18606    F  S PRV= $O(^USR(89 30.1,PRV))  Q:PRV'>0   D RULE1(P RV) I VPRM AX,VPRI'<V PRMAX Q
  18607   "RTN","VPR EASU",41,0 )
  18608    I PRV'>0  S VPRFINI= 1
  18609   "RTN","VPR EASU",42,0 )
  18610    Q
  18611   "RTN","VPR EASU",43,0 )
  18612    ;
  18613   "RTN","VPR EASU",44,0 )
  18614   RULE1(IEN)  ;
  18615   "RTN","VPR EASU",45,0 )
  18616    N $ES,$ET ,ERRMSG
  18617   "RTN","VPR EASU",46,0 )
  18618    S ERRMSG= $$ERRMSG^V PREF("ASU  Rule",IEN)
  18619   "RTN","VPR EASU",47,0 )
  18620    S $ET="D  ERRHDLR^VP RDERRH"
  18621   "RTN","VPR EASU",48,0 )
  18622    N VPRV,FL DS,X,Y,INR EC,DESC
  18623   "RTN","VPR EASU",49,0 )
  18624    K VPRV S  FLDS=".01: 1"
  18625   "RTN","VPR EASU",50,0 )
  18626    D GETS^DI Q(8930.1,I EN_",",FLD S,"IEN","V PRV")
  18627   "RTN","VPR EASU",51,0 )
  18628    S Y=$NA(V PRV(8930.1 ,IEN_","))
  18629   "RTN","VPR EASU",52,0 )
  18630    S INREC(" localId")= IEN,INREC( "uid")=$$S ETUID^VPRU TILS("asu- rule",,IEN )
  18631   "RTN","VPR EASU",53,0 )
  18632    S X=$G(@Y @(.01,"I") ) S:X INRE C("docDefU id")=$$SET UID^VPRUTI LS("doc-de f",,X),INR EC("docDef Name")=$G( @Y@(.01,"E "))
  18633   "RTN","VPR EASU",54,0 )
  18634    S X=$G(@Y @(.02,"I") ) S:X INRE C("statusU id")=$$SET UID^VPRUTI LS("doc-st atus",,X), INREC("sta tusName")= $G(@Y@(.02 ,"E"))
  18635   "RTN","VPR EASU",55,0 )
  18636    S X=$G(@Y @(.03,"I") ) S:X INRE C("actionU id")=$$SET UID^VPRUTI LS("doc-ac tion",,X), INREC("act ionName")= $G(@Y@(.03 ,"E"))
  18637   "RTN","VPR EASU",56,0 )
  18638    S X=$G(@Y @(.04,"I") ) S:X INRE C("userCla ssUid")=$$ SETUID^VPR UTILS("asu -class",,X ),INREC("u serClassNa me")=$G(@Y @(.04,"E") )
  18639   "RTN","VPR EASU",57,0 )
  18640    S X=$G(@Y @(.05,"I") ),INREC("i sAnd")=$S( X="&":"tru e",1:"fals e") ;,INRE C("isOr")= $S(X="!":" true",1:"f alse")
  18641   "RTN","VPR EASU",58,0 )
  18642    S X=$G(@Y @(.06,"I") ) S:X INRE C("userRol eUid")=$$S ETUID^VPRU TILS("asu- role",,X), INREC("use rRoleName" )=$G(@Y@(. 06,"E"))
  18643   "RTN","VPR EASU",59,0 )
  18644    I $D(@Y@( 1)) D
  18645   "RTN","VPR EASU",60,0 )
  18646    . N I S I =0 F  S I= $O(@Y@(1,I )) Q:I<1   S DESC(I)= @Y@(1,I)
  18647   "RTN","VPR EASU",61,0 )
  18648    . S INREC ("descript ion")=$$ST RING^VPRD( .DESC)
  18649   "RTN","VPR EASU",62,0 )
  18650    D ADD^VPR EF("INREC" ) S VPRLAS T=IEN
  18651   "RTN","VPR EASU",63,0 )
  18652    Q
  18653   "RTN","VPR EASU",64,0 )
  18654    ;
  18655   "RTN","VPR EASU",65,0 )
  18656   ROLE ; --  USR Role f ile #8930. 2
  18657   "RTN","VPR EASU",66,0 )
  18658    N PRV S P RV=+$G(VPR LAST)
  18659   "RTN","VPR EASU",67,0 )
  18660    S VPRCNT= $$TOTAL^VP REF("^USR( 8930.2)")
  18661   "RTN","VPR EASU",68,0 )
  18662    I PRV=0 S  PRV=.9
  18663   "RTN","VPR EASU",69,0 )
  18664    I $L(VPRI D) D ROLE1 (VPRID) Q
  18665   "RTN","VPR EASU",70,0 )
  18666    F  S PRV= $O(^USR(89 30.2,PRV))  Q:PRV'>0   D ROLE1(P RV) I VPRM AX,VPRI'<V PRMAX Q
  18667   "RTN","VPR EASU",71,0 )
  18668    I PRV'>0  S VPRFINI= 1
  18669   "RTN","VPR EASU",72,0 )
  18670    Q
  18671   "RTN","VPR EASU",73,0 )
  18672    ;
  18673   "RTN","VPR EASU",74,0 )
  18674   ROLE1(IEN)  ;
  18675   "RTN","VPR EASU",75,0 )
  18676    N $ES,$ET ,ERRMSG
  18677   "RTN","VPR EASU",76,0 )
  18678    S ERRMSG= $$ERRMSG^V PREF("User  Rule",IEN )
  18679   "RTN","VPR EASU",77,0 )
  18680    S $ET="D  ERRHDLR^VP RDERRH"
  18681   "RTN","VPR EASU",78,0 )
  18682    N VPRV,FL DS,X,Y,INR EC
  18683   "RTN","VPR EASU",79,0 )
  18684    K VPRV S  FLDS=".01: .03"
  18685   "RTN","VPR EASU",80,0 )
  18686    D GETS^DI Q(8930.2,I EN_",",FLD S,"IEN","V PRV")
  18687   "RTN","VPR EASU",81,0 )
  18688    S Y=$NA(V PRV(8930.2 ,IEN_","))
  18689   "RTN","VPR EASU",82,0 )
  18690    S INREC(" name")=$G( @Y@(.01,"E "))
  18691   "RTN","VPR EASU",83,0 )
  18692    S INREC(" uid")=$$SE TUID^VPRUT ILS("asu-r ole",,IEN)
  18693   "RTN","VPR EASU",84,0 )
  18694    S INREC(" displayNam e")=$G(@Y@ (.02,"E"))
  18695   "RTN","VPR EASU",85,0 )
  18696    S INREC(" abbreviati on")=$G(@Y @(.03,"E") )
  18697   "RTN","VPR EASU",86,0 )
  18698    D ADD^VPR EF("INREC" ) S VPRLAS T=IEN
  18699   "RTN","VPR EASU",87,0 )
  18700    Q
  18701   "RTN","VPR EASU",88,0 )
  18702    ;
  18703   "RTN","VPR EASU",89,0 )
  18704   ACTION ; - - USR Acti on file #8 930.8
  18705   "RTN","VPR EASU",90,0 )
  18706    N PRV S P RV=+$G(VPR LAST)
  18707   "RTN","VPR EASU",91,0 )
  18708    S VPRCNT= $$TOTAL^VP REF("^USR( 8930.8)")
  18709   "RTN","VPR EASU",92,0 )
  18710    I PRV=0 S  PRV=.9
  18711   "RTN","VPR EASU",93,0 )
  18712    I $L(VPRI D) D ACT1( VPRID) Q
  18713   "RTN","VPR EASU",94,0 )
  18714    F  S PRV= $O(^USR(89 30.8,PRV))  Q:PRV'>0   D ACT1(PR V) I VPRMA X,VPRI'<VP RMAX Q
  18715   "RTN","VPR EASU",95,0 )
  18716    I PRV'>0  S VPRFINI= 1
  18717   "RTN","VPR EASU",96,0 )
  18718    Q
  18719   "RTN","VPR EASU",97,0 )
  18720    ;
  18721   "RTN","VPR EASU",98,0 )
  18722   ACT1(IEN)  ;
  18723   "RTN","VPR EASU",99,0 )
  18724    N $ES,$ET ,ERRMSG
  18725   "RTN","VPR EASU",100, 0)
  18726    S ERRMSG= $$ERRMSG^V PREF("ASU  Action",IE N)
  18727   "RTN","VPR EASU",101, 0)
  18728    S $ET="D  ERRHDLR^VP RDERRH"
  18729   "RTN","VPR EASU",102, 0)
  18730    N VPRV,FL DS,X,Y,INR EC
  18731   "RTN","VPR EASU",103, 0)
  18732    K VPRV S  FLDS=".01: .08;1*"
  18733   "RTN","VPR EASU",104, 0)
  18734    D GETS^DI Q(8930.8,I EN_",",FLD S,"IEN","V PRV")
  18735   "RTN","VPR EASU",105, 0)
  18736    S Y=$NA(V PRV(8930.8 ,IEN_","))
  18737   "RTN","VPR EASU",106, 0)
  18738    S INREC(" name")=$G( @Y@(.01,"E ")),INREC( "actionUid ")=$$SETUI D^VPRUTILS ("doc-acti on",,IEN)
  18739   "RTN","VPR EASU",107, 0)
  18740    ; INREC(" isAuthoriz ation")=$S (@Y@(.02," E")="A":"t rue",1:"fa lse")
  18741   "RTN","VPR EASU",108, 0)
  18742    ; INREC(" isSubscrip tion")=$S( @Y@(.02,"E ")="S":"tr ue",1:"fal se")
  18743   "RTN","VPR EASU",109, 0)
  18744    S INREC(" eventType" )=$G(@Y@(. 02,"E"))
  18745   "RTN","VPR EASU",110, 0)
  18746    S INREC(" appliesTo" )=$G(@Y@(. 03,"E"))
  18747   "RTN","VPR EASU",111, 0)
  18748    S INREC(" userVerb") =$G(@Y@(.0 5,"E"))
  18749   "RTN","VPR EASU",112, 0)
  18750    S INREC(" documentVe rb")=$G(@Y @(.06,"E") )
  18751   "RTN","VPR EASU",113, 0)
  18752    S INREC(" userVerbMo difier")=$ G(@Y@(.07, "E"))
  18753   "RTN","VPR EASU",114, 0)
  18754    S INREC(" identifyin gPhrase")= $G(@Y@(.08 ,"E"))
  18755   "RTN","VPR EASU",115, 0)
  18756    I $D(VPRV (8930.81))  D
  18757   "RTN","VPR EASU",116, 0)
  18758    . N CNT,S NODE S CNT =0,SNODE=" "
  18759   "RTN","VPR EASU",117, 0)
  18760    . F  S SN ODE=$O(VPR V(8930.81, SNODE)) Q: SNODE=""   D
  18761   "RTN","VPR EASU",118, 0)
  18762    . . S CNT =CNT+1,INR EC("implie dAction",C NT,"name") =VPRV(8930 .81,SNODE, .01,"E")
  18763   "RTN","VPR EASU",119, 0)
  18764    . . S X=V PRV(8930.8 1,SNODE,.0 1,"I"),INR EC("implie dAction",C NT,"uid")= $$SETUID^V PRUTILS("d oc-action" ,,X)
  18765   "RTN","VPR EASU",120, 0)
  18766    D ADD^VPR EF("INREC" ) S VPRLAS T=IEN
  18767   "RTN","VPR EASU",121, 0)
  18768    Q
  18769   "RTN","VPR EASU",122, 0)
  18770    ;
  18771   "RTN","VPR EASU",123, 0)
  18772   STATUS ; - - USR Reco rd Status  file #8930 .6
  18773   "RTN","VPR EASU",124, 0)
  18774    N PRV S P RV=+$G(VPR LAST)
  18775   "RTN","VPR EASU",125, 0)
  18776    S VPRCNT= $$TOTAL^VP REF("^USR( 8930.6)")
  18777   "RTN","VPR EASU",126, 0)
  18778    I PRV=0 S  PRV=.9
  18779   "RTN","VPR EASU",127, 0)
  18780    I $L(VPRI D) D STS1( VPRID) Q
  18781   "RTN","VPR EASU",128, 0)
  18782    F  S PRV= $O(^USR(89 30.6,PRV))  Q:PRV'>0   D STS1(PR V) I VPRMA X,VPRI'<VP RMAX Q
  18783   "RTN","VPR EASU",129, 0)
  18784    I PRV'>0  S VPRFINI= 1
  18785   "RTN","VPR EASU",130, 0)
  18786    Q
  18787   "RTN","VPR EASU",131, 0)
  18788    ;
  18789   "RTN","VPR EASU",132, 0)
  18790   STS1(IEN)  ;
  18791   "RTN","VPR EASU",133, 0)
  18792    N $ES,$ET ,ERRMSG
  18793   "RTN","VPR EASU",134, 0)
  18794    S ERRMSG= $$ERRMSG^V PREF("ASU  Status",IE N)
  18795   "RTN","VPR EASU",135, 0)
  18796    S $ET="D  ERRHDLR^VP RDERRH"
  18797   "RTN","VPR EASU",136, 0)
  18798    N VPRV,FL DS,Y,INREC
  18799   "RTN","VPR EASU",137, 0)
  18800    K VPRV S  FLDS=".01: .04"
  18801   "RTN","VPR EASU",138, 0)
  18802    D GETS^DI Q(8930.6,I EN_",",FLD S,"IEN","V PRV")
  18803   "RTN","VPR EASU",139, 0)
  18804    S Y=$NA(V PRV(8930.6 ,IEN_","))
  18805   "RTN","VPR EASU",140, 0)
  18806    S INREC(" name")=$G( @Y@(.01,"E "))
  18807   "RTN","VPR EASU",141, 0)
  18808    S INREC(" uid")=$$SE TUID^VPRUT ILS("doc-s tatus",,IE N)
  18809   "RTN","VPR EASU",142, 0)
  18810    S INREC(" abbreviati on")=$G(@Y @(.02,"E") )
  18811   "RTN","VPR EASU",143, 0)
  18812    S INREC(" sequence") =$G(@Y@(.0 3,"E"))
  18813   "RTN","VPR EASU",144, 0)
  18814    S INREC(" appliesTo" )=$G(@Y@(. 04,"E"))
  18815   "RTN","VPR EASU",145, 0)
  18816    D ADD^VPR EF("INREC" ) S VPRLAS T=IEN
  18817   "RTN","VPR EASU",146, 0)
  18818    Q
  18819   "RTN","VPR EASU",147, 0)
  18820    ;
  18821   "RTN","VPR EASU",148, 0)
  18822   DEF ; -- T IU Documen t Definiti on file #8 925.1
  18823   "RTN","VPR EASU",149, 0)
  18824    N PRV S P RV=+$G(VPR LAST)
  18825   "RTN","VPR EASU",150, 0)
  18826    S VPRCNT= $$TOTAL^VP REF("^TIU( 8925.1)")
  18827   "RTN","VPR EASU",151, 0)
  18828    I PRV=0 S  PRV=.9
  18829   "RTN","VPR EASU",152, 0)
  18830    I $L(VPRI D) D DEF1( VPRID) Q
  18831   "RTN","VPR EASU",153, 0)
  18832    F  S PRV= $O(^TIU(89 25.1,PRV))  Q:PRV'>0   D DEF1(PR V) I VPRMA X,VPRI'<VP RMAX Q
  18833   "RTN","VPR EASU",154, 0)
  18834    I PRV'>0  S VPRFINI= 1
  18835   "RTN","VPR EASU",155, 0)
  18836    Q
  18837   "RTN","VPR EASU",156, 0)
  18838    ;
  18839   "RTN","VPR EASU",157, 0)
  18840   DEF1(IEN)  ;
  18841   "RTN","VPR EASU",158, 0)
  18842    N $ES,$ET ,ERRMSG
  18843   "RTN","VPR EASU",159, 0)
  18844    S ERRMSG= $$ERRMSG^V PREF("TIU  Doc Def",I EN)
  18845   "RTN","VPR EASU",160, 0)
  18846    S $ET="D  ERRHDLR^VP RDERRH"
  18847   "RTN","VPR EASU",161, 0)
  18848    N VPRV,FL DS,X,Y,I,I NREC
  18849   "RTN","VPR EASU",162, 0)
  18850    K VPRV S  FLDS=".01: .14;1501"
  18851   "RTN","VPR EASU",163, 0)
  18852    D GETS^DI Q(8925.1,I EN_",",FLD S,"IEN","V PRV")
  18853   "RTN","VPR EASU",164, 0)
  18854    S Y=$NA(V PRV(8925.1 ,IEN_","))
  18855   "RTN","VPR EASU",165, 0)
  18856    S INREC(" name")=$G( @Y@(.01,"E "))
  18857   "RTN","VPR EASU",166, 0)
  18858    S INREC(" uid")=$$SE TUID^VPRUT ILS("doc-d ef",,IEN)
  18859   "RTN","VPR EASU",167, 0)
  18860    S INREC(" abbreviati on")=$G(@Y @(.02,"E") )
  18861   "RTN","VPR EASU",168, 0)
  18862    S INREC(" displayNam e")=$G(@Y@ (.03,"E"))
  18863   "RTN","VPR EASU",169, 0)
  18864    S INREC(" typeName") =$G(@Y@(.0 4,"E"))
  18865   "RTN","VPR EASU",170, 0)
  18866    S INREC(" typeUid")= $$SETUID^V PRUTILS("d oc-type",, $G(@Y@(.04 ,"I")))
  18867   "RTN","VPR EASU",171, 0)
  18868    S X=$G(@Y @(.05,"I") ) I X D
  18869   "RTN","VPR EASU",172, 0)
  18870    . S INREC ("ownerUid ")=$$SETUI D^VPRUTILS ("user",,X )
  18871   "RTN","VPR EASU",173, 0)
  18872    . S INREC ("ownerNam e")=$G(@Y@ (.05,"E"))
  18873   "RTN","VPR EASU",174, 0)
  18874    S X=$G(@Y @(.06,"I") ) S:X INRE C("classOw ner")=$$SE TUID^VPRUT ILS("asu-c lass",,X)
  18875   "RTN","VPR EASU",175, 0)
  18876    S X=$G(@Y @(.07,"I") ) I X D
  18877   "RTN","VPR EASU",176, 0)
  18878    . S INREC ("statusUi d")=$$SETU ID^VPRUTIL S("doc-sta tus",,X)
  18879   "RTN","VPR EASU",177, 0)
  18880    . S INREC ("statusNa me")=$G(@Y @(.07,"E") )
  18881   "RTN","VPR EASU",178, 0)
  18882    S X=$G(@Y @(.1,"I"))  S:X INREC ("shared") ="true"
  18883   "RTN","VPR EASU",179, 0)
  18884    S X=$G(@Y @(.13,"I") ) S:X INRE C("nationa lStandard" )="true"
  18885   "RTN","VPR EASU",180, 0)
  18886    S X=$G(@Y @(.14,"I") ) S:X INRE C("posting Code")=$$S ETUID^VPRU TILS("doc- posting",, X)
  18887   "RTN","VPR EASU",181, 0)
  18888    S I=0 F   S I=$O(^TI U(8925.1,I EN,10,I))  Q:I<1  S X =+$G(^(I,0 )) D
  18889   "RTN","VPR EASU",182, 0)
  18890    . S INREC ("item",I, "uid")=$$S ETUID^VPRU TILS("doc- def",,X)
  18891   "RTN","VPR EASU",183, 0)
  18892    . S INREC ("item",I, "name")=$$ GET1^DIQ(8 925.1,X_", ",.01)
  18893   "RTN","VPR EASU",184, 0)
  18894    ; nationa l title in fo
  18895   "RTN","VPR EASU",185, 0)
  18896    S X=$G(@Y @(1501,"I" )) I X D   ;National  Title + at tributes
  18897   "RTN","VPR EASU",186, 0)
  18898    . N IENS, TIU,DA,FNU M,NAME
  18899   "RTN","VPR EASU",187, 0)
  18900    . S IENS= X_"," D GE TS^DIQ(892 6.1,IENS," *","IE","T IU")
  18901   "RTN","VPR EASU",188, 0)
  18902    . S INREC ("national Title","vu id")="urn: va:vuid:"_ $G(TIU(892 6.1,IENS,9 9.99,"E"))
  18903   "RTN","VPR EASU",189, 0)
  18904    . S INREC ("national Title","na me")=$G(TI U(8926.1,I ENS,.01,"E "))
  18905   "RTN","VPR EASU",190, 0)
  18906    . F I=".0 4^Subject^ 2",".05^Ro le^3",".06 ^Setting^4 ",".07^Ser vice^5",". 08^Type^6"  D
  18907   "RTN","VPR EASU",191, 0)
  18908    .. S DA=+ $G(TIU(892 6.1,IENS,+ I,"I")) Q: DA'>0
  18909   "RTN","VPR EASU",192, 0)
  18910    .. S FNUM ="8926."_+ $P(I,U,3), NAME=$$LOW ^XLFSTR($P (I,U,2))
  18911   "RTN","VPR EASU",193, 0)
  18912    .. S INRE C("nationa lTitle"_$P (I,U,2),"v uid")="urn :va:vuid:" _$$VUID^VP RD(DA,FNUM )
  18913   "RTN","VPR EASU",194, 0)
  18914    .. S INRE C("nationa lTitle"_$P (I,U,2),"n ame")=$G(T IU(8926.1, IENS,+I,"E "))
  18915   "RTN","VPR EASU",195, 0)
  18916    ;
  18917   "RTN","VPR EASU",196, 0)
  18918    D ADD^VPR EF("INREC" ) S VPRLAS T=IEN
  18919   "RTN","VPR EASU",197, 0)
  18920    Q
  18921   "RTN","VPR EF")
  18922   0^54^B1608 51666
  18923   "RTN","VPR EF",1,0)
  18924   VPREF ;SLC /MKB -- Se rve VistA  operationa l data as  JSON via R PC ; 10/18 /12 6:26pm
  18925   "RTN","VPR EF",2,0)
  18926    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  18927   "RTN","VPR EF",3,0)
  18928    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  18929   "RTN","VPR EF",4,0)
  18930    ;
  18931   "RTN","VPR EF",5,0)
  18932   GET(VPR,FI LTER) ; --  Return se arch resul ts as JSON  in @VPR@( n)
  18933   "RTN","VPR EF",6,0)
  18934    ; RPC = V PR GET OPE RATIONAL D ATA
  18935   "RTN","VPR EF",7,0)
  18936    ; where F ILTER("dom ain")  = n ame of des ired data  type (see  $$TAG)
  18937   "RTN","VPR EF",8,0)
  18938    ;       F ILTER("lim it")   = m aximum num ber of ite ms to retu rn [opt]
  18939   "RTN","VPR EF",9,0)
  18940    ;       F ILTER("sta rt")   = i en to star t search f rom           [opt]
  18941   "RTN","VPR EF",10,0)
  18942    ;       F ILTER("id" )      = s ingle item  id to ret urn           [opt]
  18943   "RTN","VPR EF",11,0)
  18944    ;
  18945   "RTN","VPR EF",12,0)
  18946    N VPRSYS, TYPE,VPRMA X,VPRI,VPR ID,VPRERR, VPRTN,VPRL AST,VPRCNT ,VPRFINI
  18947   "RTN","VPR EF",13,0)
  18948    S VPR=$NA (^TMP("VPR ",$J)),VPR I=0 K @VPR
  18949   "RTN","VPR EF",14,0)
  18950    S VPRSYS= $$GET^XPAR ("SYS","VP R SYSTEM N AME")
  18951   "RTN","VPR EF",15,0)
  18952    ;
  18953   "RTN","VPR EF",16,0)
  18954    ; parse &  validate  input para meters
  18955   "RTN","VPR EF",17,0)
  18956    S TYPE=$P ($G(FILTER ("domain") ),"#") ;,T YPE=$$LOW^ XLFSTR(TYP E)
  18957   "RTN","VPR EF",18,0)
  18958    S VPRMAX= +$G(FILTER ("limit")) ,VPRCNT=0
  18959   "RTN","VPR EF",19,0)
  18960    S VPRLAST =+$G(FILTE R("start") )
  18961   "RTN","VPR EF",20,0)
  18962    S VPRID=$ G(FILTER(" id"))
  18963   "RTN","VPR EF",21,0)
  18964    ;
  18965   "RTN","VPR EF",22,0)
  18966    ;set erro r trap
  18967   "RTN","VPR EF",23,0)
  18968    K ^TMP($J ,"VPR ERRO R")
  18969   "RTN","VPR EF",24,0)
  18970    ;
  18971   "RTN","VPR EF",25,0)
  18972    ; extract  data
  18973   "RTN","VPR EF",26,0)
  18974    I TYPE=""  S VPRERR= "Missing o r invalid  reference  type" G GT Q
  18975   "RTN","VPR EF",27,0)
  18976    I $D(ZTQU EUED) S VP R=$NA(^XTM P(VPRBATCH ,VPRFZTSK, FILTER("do main"))) K  @VPR
  18977   "RTN","VPR EF",28,0)
  18978    I TYPE="n ew",$L($T( EN^VPREFX) ) D EN^VPR EFX(VPRID, VPRMAX) Q
  18979   "RTN","VPR EF",29,0)
  18980    S VPRTN=$ $TAG(TYPE)  Q:'$L(VPR TN)  ;D ER R(2) Q
  18981   "RTN","VPR EF",30,0)
  18982    ;N $ES,$E T,ERRMSG
  18983   "RTN","VPR EF",31,0)
  18984    ;S $ET="D  ERRHDLR^V PRDERRH",E RRMSG="A M UMPS error  occurred  while extr acting "_T YPE_" data "
  18985   "RTN","VPR EF",32,0)
  18986    D @VPRTN
  18987   "RTN","VPR EF",33,0)
  18988    ;
  18989   "RTN","VPR EF",34,0)
  18990   GTQ ; add  item count  and termi nating cha racters
  18991   "RTN","VPR EF",35,0)
  18992    N ERROR I  $D(^TMP($ J,"VPR ERR OR"))>0 D  BUILDERR(. ERROR) S E RROR(1)=ER ROR(1)_"}"
  18993   "RTN","VPR EF",36,0)
  18994    I +$G(FIL TER("noHea d"))=1 D   Q
  18995   "RTN","VPR EF",37,0)
  18996    .S @VPR@( "total")=+ $G(VPRI)
  18997   "RTN","VPR EF",38,0)
  18998    .S @VPR@( "last")=VP RLAST
  18999   "RTN","VPR EF",39,0)
  19000    .S @VPR@( "finished" )=+$G(VPRF INI)
  19001   "RTN","VPR EF",40,0)
  19002    .I $L($G( ERROR(1))) >1 S @VPR@ ("error")= ERROR(1)
  19003   "RTN","VPR EF",41,0)
  19004    I '$D(@VP R)!'$G(VPR I) D  Q
  19005   "RTN","VPR EF",42,0)
  19006    .I '$D(^T MP($J,"VPR  ERROR"))  S @VPR@(1) ="""data"" :{""totalI tems"":0," "items"":[ ]}}" Q
  19007   "RTN","VPR EF",43,0)
  19008    .S @VPR@( 1)="""data "":{""tota lItems"":0 ,""items"" :[]},"
  19009   "RTN","VPR EF",44,0)
  19010    .M @VPR@( 2)=ERROR
  19011   "RTN","VPR EF",45,0)
  19012    ;
  19013   "RTN","VPR EF",46,0)
  19014    I $D(@VPR ),$G(VPRI)  D
  19015   "RTN","VPR EF",47,0)
  19016    . S @VPR@ (.5)="{""a piVersion" ":""1.01"" ,""data"": {""updated "":"""_$$H L7NOW_""", ""currentI temCount"" :"_VPRI
  19017   "RTN","VPR EF",48,0)
  19018    . S:$G(VP RCNT) @VPR @(.5)=@VPR @(.5)_","" totalItems "":"_VPRCN T
  19019   "RTN","VPR EF",49,0)
  19020    . S:$G(VP RLAST) @VP R@(.5)=@VP R@(.5)_"," "last"":"_ VPRLAST
  19021   "RTN","VPR EF",50,0)
  19022    . S @VPR@ (.5)=@VPR@ (.5)_",""i tems"":["
  19023   "RTN","VPR EF",51,0)
  19024    . S VPRI= VPRI+1,@VP R@(VPRI)=$ S($D(^TMP( $J,"VPR ER ROR"))>0:" ]}",1:"]}} ")
  19025   "RTN","VPR EF",52,0)
  19026    I $D(^TMP ($J,"VPR E RROR"))>0  S VPRI=VPR I+1,@VPR@( VPRI,.3)=" ," M @VPR@ (VPRI)=ERR OR ;S VPRI =VPRI+1,@V PR@(VPRI)= "}"
  19027   "RTN","VPR EF",53,0)
  19028    K ^TMP($J ,"VPR ERRO R")
  19029   "RTN","VPR EF",54,0)
  19030    Q
  19031   "RTN","VPR EF",55,0)
  19032    ;
  19033   "RTN","VPR EF",56,0)
  19034   BUILDERR(R ESULT) ; - - build er ror array
  19035   "RTN","VPR EF",57,0)
  19036    N CNT,COU NT,DOM,DOM CNT,ERRMSG ,ERROR,FIE LD,MESSAGE ,MSG,MSGCN T,T,TEMP
  19037   "RTN","VPR EF",58,0)
  19038    S COUNT=$ G(^TMP($J, "VPR ERROR ","# of Er rors"))
  19039   "RTN","VPR EF",59,0)
  19040    S MESSAGE ="A mumps  error occu rred when  extracting  data. A t otal of "_ COUNT_" oc curred.\n\ r"
  19041   "RTN","VPR EF",60,0)
  19042    S CNT=1,E RROR("erro r","messag e","\",CNT )="A mumps  error occ urred when  extractin g patient  data. A to tal of "_C OUNT_" occ urred.\n\r "
  19043   "RTN","VPR EF",61,0)
  19044    S MSGCNT= 0 F  S MSG CNT=$O(^TM P($J,"VPR  ERROR","ER ROR MESSAG E",MSGCNT) ) Q:MSGCNT '>0  D
  19045   "RTN","VPR EF",62,0)
  19046    . S CNT=C NT+1,MESSA GE=MESSAGE _$G(^TMP($ J,"VPR ERR OR","ERROR  MESSAGE", MSGCNT))_" \n\r"
  19047   "RTN","VPR EF",63,0)
  19048    S RESULT( 1)="""erro r"":{""mes sage"":"_" """_MESSAG E_""""_"}"
  19049   "RTN","VPR EF",64,0)
  19050    Q
  19051   "RTN","VPR EF",65,0)
  19052    ;
  19053   "RTN","VPR EF",66,0)
  19054   TAG(X) ; - - Return l inetag for  reference  domain X
  19055   "RTN","VPR EF",67,0)
  19056    N Y S Y=" VPR",X=$G( X)
  19057   "RTN","VPR EF",68,0)
  19058    ; default  = VPR Obj ect (vario us types)
  19059   "RTN","VPR EF",69,0)
  19060    I X="loca tion"       S Y="LOC"
  19061   "RTN","VPR EF",70,0)
  19062    I X="pt-s elect"      S Y="PAT"
  19063   "RTN","VPR EF",71,0)
  19064    I X="pers on"         S Y="NP"
  19065   "RTN","VPR EF",72,0)
  19066    I X="user "           S Y="NP"
  19067   "RTN","VPR EF",73,0)
  19068    I X="rost er"         S Y="ROS"
  19069   "RTN","VPR EF",74,0)
  19070    I X="labg roup"       S Y="LABG RP"
  19071   "RTN","VPR EF",75,0)
  19072    I X="labp anel"       S Y="LABP NL"
  19073   "RTN","VPR EF",76,0)
  19074    I X["orde rable"      S Y="OI"
  19075   "RTN","VPR EF",77,0)
  19076    I X["sche dule"       S Y="SCHE DULE"
  19077   "RTN","VPR EF",78,0)
  19078    I X["rout e"          S Y="ROUT E"
  19079   "RTN","VPR EF",79,0)
  19080    I X["quic k"          S Y="QO"
  19081   "RTN","VPR EF",80,0)
  19082    I X="disp layGroup"   S Y="ODG"
  19083   "RTN","VPR EF",81,0)
  19084    I X["asu- "           S Y="ASU"
  19085   "RTN","VPR EF",82,0)
  19086    I X["doc- "           S Y="ASU"
  19087   "RTN","VPR EF",83,0)
  19088    I X["clio term"       S Y="MDTE RMS" ;blj
  19089   "RTN","VPR EF",84,0)
  19090    Q Y
  19091   "RTN","VPR EF",85,0)
  19092    ;
  19093   "RTN","VPR EF",86,0)
  19094   ERR(X,VAL)  ; -- retu rn error m essage
  19095   "RTN","VPR EF",87,0)
  19096    N MSG  S  MSG="Error "
  19097   "RTN","VPR EF",88,0)
  19098    I X=2  S  MSG="Domai n type '"_ $G(VAL)_"'  not recog nized"
  19099   "RTN","VPR EF",89,0)
  19100    I X=3  S  MSG="UID ' "_$G(VAL)_ "' not fou nd"
  19101   "RTN","VPR EF",90,0)
  19102    I X=99 S  MSG="Unkno wn request "
  19103   "RTN","VPR EF",91,0)
  19104    Q MSG
  19105   "RTN","VPR EF",92,0)
  19106    ;
  19107   "RTN","VPR EF",93,0)
  19108   ERRMSG(X,V AL) ; -- r eturn erro r message,  if needed
  19109   "RTN","VPR EF",94,0)
  19110    N Y S Y=" A MUMPS er ror occurr ed while e xtracting  "_X_" data "
  19111   "RTN","VPR EF",95,0)
  19112    S:$G(VAL)  Y=Y_", ie n "_VAL
  19113   "RTN","VPR EF",96,0)
  19114    Q Y
  19115   "RTN","VPR EF",97,0)
  19116    ;
  19117   "RTN","VPR EF",98,0)
  19118   ERRQ ; --  Quit for e rror handl ing
  19119   "RTN","VPR EF",99,0)
  19120    Q
  19121   "RTN","VPR EF",100,0)
  19122    ;
  19123   "RTN","VPR EF",101,0)
  19124   HL7NOW() ;  -- Return  current t ime in HL7  format
  19125   "RTN","VPR EF",102,0)
  19126    Q $P($$FM THL7^XLFDT ($$NOW^XLF DT),"-")
  19127   "RTN","VPR EF",103,0)
  19128    ;
  19129   "RTN","VPR EF",104,0)
  19130   ALL() ;
  19131   "RTN","VPR EF",105,0)
  19132    Q "locati on;patient ;person;or derable;sc hedule;rou te;quick;d isplayGrou p;asu-clas s;asu-rule ;asu-role; doc-action ;doc-statu s;clioterm "
  19133   "RTN","VPR EF",106,0)
  19134    ;
  19135   "RTN","VPR EF",107,0)
  19136   ADD(ITEM)  ; -- add I TEM to @VP R@(VPRI)
  19137   "RTN","VPR EF",108,0)
  19138    N VPRY,VP RERR
  19139   "RTN","VPR EF",109,0)
  19140    D ENCODE^ VPRJSON(IT EM,"VPRY", "VPRERR")
  19141   "RTN","VPR EF",110,0)
  19142    I $D(VPRE RR) D  ;re turn ERRor  instead o f ITEM
  19143   "RTN","VPR EF",111,0)
  19144    . N VPRTM P,VPRTXT,V PRITM
  19145   "RTN","VPR EF",112,0)
  19146    . M VPRIT M=@ITEM K  VPRY
  19147   "RTN","VPR EF",113,0)
  19148    . S VPRTX T(1)="Prob lem encodi ng json ou tput."
  19149   "RTN","VPR EF",114,0)
  19150    . D SETER ROR^VPRUTI LS(.VPRTMP ,.VPRERR,. VPRTXT,.VP RITM)
  19151   "RTN","VPR EF",115,0)
  19152    . K VPRER R D ENCODE ^VPRJSON(" VPRTMP","V PRY","VPRE RR")
  19153   "RTN","VPR EF",116,0)
  19154    I $D(VPRY ) D
  19155   "RTN","VPR EF",117,0)
  19156    . I VPRI  D COMMA(VP RI)
  19157   "RTN","VPR EF",118,0)
  19158    . ;I VPRI ,'$G(FILTE R("noHead" )) D COMMA (VPRI)
  19159   "RTN","VPR EF",119,0)
  19160    . S VPRI= VPRI+1 M @ VPR@(VPRI) =VPRY
  19161   "RTN","VPR EF",120,0)
  19162    Q
  19163   "RTN","VPR EF",121,0)
  19164    ;
  19165   "RTN","VPR EF",122,0)
  19166   COMMA(I) ;  -- add co mma betwee n items
  19167   "RTN","VPR EF",123,0)
  19168    I $D(ZTQU EUED) Q
  19169   "RTN","VPR EF",124,0)
  19170    N J S J=+ $O(@VPR@(I ,"A"),-1)  ;last sub- node for i tem I
  19171   "RTN","VPR EF",125,0)
  19172    S J=J+1,@ VPR@(I,J)= ","
  19173   "RTN","VPR EF",126,0)
  19174    Q
  19175   "RTN","VPR EF",127,0)
  19176    ;
  19177   "RTN","VPR EF",128,0)
  19178   TOTAL(ROOT ) ; -- Ret urn total  #items in  @ROOT@(n)
  19179   "RTN","VPR EF",129,0)
  19180    Q $P($G(@ ROOT@(0)), U,4)
  19181   "RTN","VPR EF",130,0)
  19182    ;
  19183   "RTN","VPR EF",131,0)
  19184    N I,Y S ( I,Y)=0
  19185   "RTN","VPR EF",132,0)
  19186    F  S I=$O (@ROOT@(I) ) Q:I<1  S  Y=Y+1
  19187   "RTN","VPR EF",133,0)
  19188    Q Y
  19189   "RTN","VPR EF",134,0)
  19190    ;
  19191   "RTN","VPR EF",135,0)
  19192   TEST(TYPE, ID,IN) ; - - test GET , write re sults to s creen
  19193   "RTN","VPR EF",136,0)
  19194    N OUT,IDX
  19195   "RTN","VPR EF",137,0)
  19196    S U="^"
  19197   "RTN","VPR EF",138,0)
  19198    S IN("dom ain")=$G(T YPE)
  19199   "RTN","VPR EF",139,0)
  19200    S:$D(ID)  IN("id")=I D
  19201   "RTN","VPR EF",140,0)
  19202    D GET(.OU T,.IN)
  19203   "RTN","VPR EF",141,0)
  19204    ;
  19205   "RTN","VPR EF",142,0)
  19206    S IDX=OUT
  19207   "RTN","VPR EF",143,0)
  19208    F  S IDX= $Q(@IDX) Q :IDX'?1"^T MP(""VPR"" ,"1.N.E  Q :+$P(IDX," ,",2)'=$J   W !,@IDX
  19209   "RTN","VPR EF",144,0)
  19210    Q
  19211   "RTN","VPR EF",145,0)
  19212    ;
  19213   "RTN","VPR EF",146,0)
  19214    ; ** Refe rence file  searches,  using FIL TER("param eter")
  19215   "RTN","VPR EF",147,0)
  19216    ;
  19217   "RTN","VPR EF",148,0)
  19218   PAT ; -- R eturn Pati ents [use  shorter DE M^VPRDJ00? ]
  19219   "RTN","VPR EF",149,0)
  19220    N DFN,PAT ,VPRPOPD
  19221   "RTN","VPR EF",150,0)
  19222    S VPRPOPD =1
  19223   "RTN","VPR EF",151,0)
  19224    S VPRCNT= $$TOTAL("^ DPT")
  19225   "RTN","VPR EF",152,0)
  19226    I $G(VPRI D) S DFN=+ VPRID D LK UP^VPRDJ00  Q
  19227   "RTN","VPR EF",153,0)
  19228    ;I $G(VPR ID) S DFN= VPRID D DP T1^VPRDJ00  Q
  19229   "RTN","VPR EF",154,0)
  19230    N ERRMSG  S ERRMSG=" A mumps er ror occurr ed while e xtracting  patients."
  19231   "RTN","VPR EF",155,0)
  19232    ;Q:VPRI'< VPRMAX
  19233   "RTN","VPR EF",156,0)
  19234    S DFN=+$G (VPRLAST)  F  S DFN=$ O(^DPT(DFN )) Q:DFN<1   D  I VPR MAX>0,VPRI '<VPRMAX Q
  19235   "RTN","VPR EF",157,0)
  19236    . N $ES,$ ET
  19237   "RTN","VPR EF",158,0)
  19238    . S $ET=" D ERRHDLR^ VPRDERRH"
  19239   "RTN","VPR EF",159,0)
  19240    . I $P($G (^DPT(DFN, 0)),U)=""  Q
  19241   "RTN","VPR EF",160,0)
  19242    . S ERRMS G=$$ERRMSG ("Patient" ,DFN)
  19243   "RTN","VPR EF",161,0)
  19244    . ;K PAT  D DPT1^VPR DJ00
  19245   "RTN","VPR EF",162,0)
  19246    . K PAT D  LKUP^VPRD J00
  19247   "RTN","VPR EF",163,0)
  19248    . S VPRLA ST=DFN
  19249   "RTN","VPR EF",164,0)
  19250    I DFN<1 S  VPRFINI=1
  19251   "RTN","VPR EF",165,0)
  19252    Q
  19253   "RTN","VPR EF",166,0)
  19254   LOC ; -- R eturn Hosp ital Locat ions
  19255   "RTN","VPR EF",167,0)
  19256    S VPRCNT= $$TOTAL("^ SC")
  19257   "RTN","VPR EF",168,0)
  19258    I $G(VPRI D) D LOC1( VPRID) Q
  19259   "RTN","VPR EF",169,0)
  19260    N HL S HL =+$G(VPRLA ST)
  19261   "RTN","VPR EF",170,0)
  19262    F  S HL=$ O(^SC(HL))  Q:HL<1  D  LOC1(HL)  I VPRMAX>0 ,VPRI'<VPR MAX Q
  19263   "RTN","VPR EF",171,0)
  19264    I HL<1 S  VPRFINI=1
  19265   "RTN","VPR EF",172,0)
  19266    Q
  19267   "RTN","VPR EF",173,0)
  19268    ;
  19269   "RTN","VPR EF",174,0)
  19270   LOC1(IEN)  ; -- get o ne locatio n
  19271   "RTN","VPR EF",175,0)
  19272    N $ES,$ET ,ERRMSG
  19273   "RTN","VPR EF",176,0)
  19274    S ERRMSG= $$ERRMSG(" Location", IEN)
  19275   "RTN","VPR EF",177,0)
  19276    S $ET="D  ERRHDLR^VP RDERRH"
  19277   "RTN","VPR EF",178,0)
  19278    N LOC,X0, X,Y
  19279   "RTN","VPR EF",179,0)
  19280    S X0=$G(^ SC(IEN,0)) ,LOC("name ")=$P(X0,U )
  19281   "RTN","VPR EF",180,0)
  19282    S LOC("lo calId")=IE N,LOC("uid ")=$$SETUI D^VPRUTILS ("location ",,IEN)
  19283   "RTN","VPR EF",181,0)
  19284    S LOC("sh ortName")= $P(X0,U,2) ,LOC("type ")=$P(X0,U ,3)
  19285   "RTN","VPR EF",182,0)
  19286    S LOC("re fId")=IEN
  19287   "RTN","VPR EF",183,0)
  19288    I $G(^SC( IEN,42))'= "" D
  19289   "RTN","VPR EF",184,0)
  19290    .I $D(^DI C(42,+^SC( IEN,42)))  S LOC("ref Id")=+^SC( IEN,42)
  19291   "RTN","VPR EF",185,0)
  19292    S X=+$P(X 0,U,4) I X  D
  19293   "RTN","VPR EF",186,0)
  19294    . S Y=$$N S^XUAF4(X) ,X=$P(Y,U, 2)_U_$P(Y, U)
  19295   "RTN","VPR EF",187,0)
  19296    . D FACIL ITY^VPRUTI LS(X,"LOC" )
  19297   "RTN","VPR EF",188,0)
  19298    I '$$ACTL OC(IEN) S  LOC("inact ive")="tru e"
  19299   "RTN","VPR EF",189,0)
  19300    D ADD("LO C") S VPRL AST=IEN
  19301   "RTN","VPR EF",190,0)
  19302    Q
  19303   "RTN","VPR EF",191,0)
  19304    ;
  19305   "RTN","VPR EF",192,0)
  19306   ACTLOC(LOC ) ; Functi on: return s TRUE if  active hos pital loca tion
  19307   "RTN","VPR EF",193,0)
  19308    ; IA# 100 40.
  19309   "RTN","VPR EF",194,0)
  19310    N D0,X I  +$G(^SC(LO C,"OOS"))  Q 0                 ;  screen ou t OOS entr y
  19311   "RTN","VPR EF",195,0)
  19312    S D0=+$G( ^SC(LOC,42 )) I D0 D  WIN^DGPMDD CF Q 'X  ;  chk out o f svc ward s
  19313   "RTN","VPR EF",196,0)
  19314    S X=$G(^S C(LOC,"I") ) I +X=0 Q  1                  ;  no inacti vate date
  19315   "RTN","VPR EF",197,0)
  19316    I DT>$P(X ,U)&($P(X, U,2)=""!(D T<$P(X,U,2 ))) Q 0  ;  chk react ivate date
  19317   "RTN","VPR EF",198,0)
  19318    Q 1                                                 ;  must stil l be activ e
  19319   "RTN","VPR EF",199,0)
  19320    ;
  19321   "RTN","VPR EF",200,0)
  19322   NP ; -- Re turn New P ersons
  19323   "RTN","VPR EF",201,0)
  19324    N PRV
  19325   "RTN","VPR EF",202,0)
  19326    S VPRCNT= $$TOTAL("^ VA(200)")
  19327   "RTN","VPR EF",203,0)
  19328    I $G(VPRI D) D NP1(V PRID) Q
  19329   "RTN","VPR EF",204,0)
  19330    S PRV=+$G (VPRLAST)  ;$S(VPRLAS T:VPRLAST, 1:.9)
  19331   "RTN","VPR EF",205,0)
  19332    I PRV=0 S  PRV=.9
  19333   "RTN","VPR EF",206,0)
  19334    F  S PRV= $O(^VA(200 ,PRV)) Q:P RV<1  D NP 1(PRV) I V PRMAX>0,VP RI'<VPRMAX  Q
  19335   "RTN","VPR EF",207,0)
  19336    I PRV<1 S  VPRFINI=1
  19337   "RTN","VPR EF",208,0)
  19338    Q
  19339   "RTN","VPR EF",209,0)
  19340    ;
  19341   "RTN","VPR EF",210,0)
  19342   NP1(IEN) ;  -- get on e person
  19343   "RTN","VPR EF",211,0)
  19344    N $ES,$ET ,ERRMSG
  19345   "RTN","VPR EF",212,0)
  19346    S ERRMSG= $$ERRMSG(" person",IE N)
  19347   "RTN","VPR EF",213,0)
  19348    S $ET="D  ERRHDLR^VP RDERRH"
  19349   "RTN","VPR EF",214,0)
  19350    N VPRV,FL DS,USER,X, Y
  19351   "RTN","VPR EF",215,0)
  19352    I $$ISPRO XY(IEN)=1  Q
  19353   "RTN","VPR EF",216,0)
  19354    K VPRV S  FLDS=".01; 4:9.2;9.5* ;19:53.8;6 54.3;.132: .138"
  19355   "RTN","VPR EF",217,0)
  19356    D GETS^DI Q(200,IEN_ ",",FLDS," IEN","VPRV ")
  19357   "RTN","VPR EF",218,0)
  19358    S Y=$NA(V PRV(200,IE N_","))
  19359   "RTN","VPR EF",219,0)
  19360    S USER("n ame")=$G(@ Y@(.01,"E" ))
  19361   "RTN","VPR EF",220,0)
  19362    S USER("l ocalId")=I EN,USER("u id")=$$SET UID^VPRUTI LS("user", ,IEN)
  19363   "RTN","VPR EF",221,0)
  19364    S:$D(@Y@( 4)) USER(" genderCode ")="urn:va :gender:"_ @Y@(4,"I") ,USER("gen derName")= @Y@(4,"E")
  19365   "RTN","VPR EF",222,0)
  19366    S X=+$P($ G(@Y@(5,"I ")),".") S :X USER("d ateOfBirth ")=$$JSOND T^VPRUTILS (X)
  19367   "RTN","VPR EF",223,0)
  19368    S X=$G(@Y @(7,"I"))  S:$L(X) US ER("disuse r")=$S(X:" true",1:"f alse")
  19369   "RTN","VPR EF",224,0)
  19370    S X=$G(@Y @(8,"E"))  S:$L(X) US ER("title" )=X
  19371   "RTN","VPR EF",225,0)
  19372    S X=$G(@Y @(9,"E"))  S:$L(X) US ER("ssn")= X
  19373   "RTN","VPR EF",226,0)
  19374    S X=$G(@Y @(9.2,"I") ) S:$L(X)  USER("term inated")=$ $JSONDT^VP RUTILS(X)
  19375   "RTN","VPR EF",227,0)
  19376    S X=+$G(@ Y@(19,"I") ) S:X USER ("delegate Code")=$$S ETUID^VPRU TILS("user ",,X),USER ("delegate Name")=$G( @Y@(19,"E" ))
  19377   "RTN","VPR EF",228,0)
  19378    S X=$G(@Y @(29,"E"))  S:$L(X) U SER("servi ce")=X
  19379   "RTN","VPR EF",229,0)
  19380    S X=$G(@Y @(53.5,"E" )) S:$L(X)  USER("pro viderClass ")=X
  19381   "RTN","VPR EF",230,0)
  19382    S X=$G(@Y @(53.6,"E" )) S:$L(X)  USER("pro viderType" )=X
  19383   "RTN","VPR EF",231,0)
  19384    S X=+$G(@ Y@(654.3," I")) S:X U SER("surro gateCode") =$$SETUID^ VPRUTILS(" user",,X), USER("surr ogateName" )=$G(@Y@(6 54.3,"E"))
  19385   "RTN","VPR EF",232,0)
  19386    S X=$G(@Y @(.132,"E" )) S:$L(X)  USER("off icePhone") =X
  19387   "RTN","VPR EF",233,0)
  19388    S X=$G(@Y @(.133,"E" )) S:$L(X)  USER("pho ne3")=X
  19389   "RTN","VPR EF",234,0)
  19390    S X=$G(@Y @(.134,"E" )) S:$L(X)  USER("pho ne4")=X
  19391   "RTN","VPR EF",235,0)
  19392    S X=$G(@Y @(.135,"E" )) S:$L(X)  USER("com mercialPho ne")=X
  19393   "RTN","VPR EF",236,0)
  19394    S X=$G(@Y @(.136,"E" )) S:$L(X)  USER("fax ")=X
  19395   "RTN","VPR EF",237,0)
  19396    S X=$G(@Y @(.137,"E" )) S:$L(X)  USER("voi cePager")= X
  19397   "RTN","VPR EF",238,0)
  19398    S X=$G(@Y @(.138,"E" )) S:$L(X)  USER("dig italPager" )=X
  19399   "RTN","VPR EF",239,0)
  19400    D KEYS(IE N)
  19401   "RTN","VPR EF",240,0)
  19402    D ADD("US ER") S VPR LAST=IEN
  19403   "RTN","VPR EF",241,0)
  19404    Q
  19405   "RTN","VPR EF",242,0)
  19406    ;
  19407   "RTN","VPR EF",243,0)
  19408   KEYS(IEN)  ; -- get u ser's keys
  19409   "RTN","VPR EF",244,0)
  19410    N VPRKEY, IENS,X,CNT
  19411   "RTN","VPR EF",245,0)
  19412    D GETS^DI Q(200,IEN_ ",","51*", "IE","VPRK EY") S CNT =0
  19413   "RTN","VPR EF",246,0)
  19414    S IENS=""  F  S IENS =$O(VPRKEY (200.051,I ENS)) Q:IE NS=""  D
  19415   "RTN","VPR EF",247,0)
  19416    . S X=$G( VPRKEY(200 .051,IENS, .01,"E")), CNT=CNT+1
  19417   "RTN","VPR EF",248,0)
  19418    . S USER( "vistaKeys ",CNT,"nam e")=X
  19419   "RTN","VPR EF",249,0)
  19420    . S X=$G( VPRKEY(200 .051,IENS, 3,"I"))
  19421   "RTN","VPR EF",250,0)
  19422    . S:X USE R("vistaKe ys",CNT,"r eviewDate" )=$$JSONDT ^VPRUTILS( X)
  19423   "RTN","VPR EF",251,0)
  19424    Q
  19425   "RTN","VPR EF",252,0)
  19426    ;
  19427   "RTN","VPR EF",253,0)
  19428   ODG ;
  19429   "RTN","VPR EF",254,0)
  19430    D ADDODG^ VPRCORD4
  19431   "RTN","VPR EF",255,0)
  19432    Q
  19433   "RTN","VPR EF",256,0)
  19434    ;
  19435   "RTN","VPR EF",257,0)
  19436   OI ;
  19437   "RTN","VPR EF",258,0)
  19438    ;I 1/0
  19439   "RTN","VPR EF",259,0)
  19440    D OI^VPRC ORD4("PS^R AP^LRT")
  19441   "RTN","VPR EF",260,0)
  19442    Q
  19443   "RTN","VPR EF",261,0)
  19444    ;
  19445   "RTN","VPR EF",262,0)
  19446   QO ;
  19447   "RTN","VPR EF",263,0)
  19448    D QO^VPRC ORD4
  19449   "RTN","VPR EF",264,0)
  19450    Q
  19451   "RTN","VPR EF",265,0)
  19452    ;
  19453   "RTN","VPR EF",266,0)
  19454   SCHEDULE ;
  19455   "RTN","VPR EF",267,0)
  19456    N RESULT
  19457   "RTN","VPR EF",268,0)
  19458    D ADDSCH^ VPRCORD4
  19459   "RTN","VPR EF",269,0)
  19460    ;D ADD("R ESULT")
  19461   "RTN","VPR EF",270,0)
  19462    Q
  19463   "RTN","VPR EF",271,0)
  19464    ;
  19465   "RTN","VPR EF",272,0)
  19466   ROUTE ;
  19467   "RTN","VPR EF",273,0)
  19468    N RESULT
  19469   "RTN","VPR EF",274,0)
  19470    D ADDROUT E^VPRCORD4
  19471   "RTN","VPR EF",275,0)
  19472    ;D ADD("R ESULT")
  19473   "RTN","VPR EF",276,0)
  19474    Q
  19475   "RTN","VPR EF",277,0)
  19476    ;
  19477   "RTN","VPR EF",278,0)
  19478   VPR ; -- R eturn VPR  Objects
  19479   "RTN","VPR EF",279,0)
  19480    N IEN
  19481   "RTN","VPR EF",280,0)
  19482    S VPRCNT= $$TOTAL("^ VPR(560.11 )")
  19483   "RTN","VPR EF",281,0)
  19484    I $L(VPRI D) D  Q
  19485   "RTN","VPR EF",282,0)
  19486    . I VPRID =+VPRID S  IEN=VPRID
  19487   "RTN","VPR EF",283,0)
  19488    . E  S IE N=+$O(^VPR (560.11,"B ",VPRID,0) )
  19489   "RTN","VPR EF",284,0)
  19490    . S ERRMS G=$$ERRMSG ("VPR Obje ct",IEN)
  19491   "RTN","VPR EF",285,0)
  19492    . D:IEN V PR1^VPRDJ0 2(560.11,I EN)
  19493   "RTN","VPR EF",286,0)
  19494    S IEN=+$G (VPRLAST)  F  S IEN=$ O(^VPR(560 .11,"C",TY PE,IEN)) Q :IEN<1  D   I VPRMAX> 0,VPRI'<VP RMAX Q
  19495   "RTN","VPR EF",287,0)
  19496    . S ERRMS G=$$ERRMSG ("VPR Obje ct",IEN)
  19497   "RTN","VPR EF",288,0)
  19498    . D VPR1^ VPRDJ02(56 0.11,IEN)  S VPRLAST= IEN
  19499   "RTN","VPR EF",289,0)
  19500    I IEN<1 S  VPRFINI=1
  19501   "RTN","VPR EF",290,0)
  19502    Q
  19503   "RTN","VPR EF",291,0)
  19504    ;
  19505   "RTN","VPR EF",292,0)
  19506   ROS ; -- R eturn rost ers
  19507   "RTN","VPR EF",293,0)
  19508    N PRV
  19509   "RTN","VPR EF",294,0)
  19510    S VPRCNT= $$TOTAL("^ VPROSTER")
  19511   "RTN","VPR EF",295,0)
  19512    I $L(VPRI D) D:$D(^V PROSTER(VP RID,0)) RO S1(VPRID)  Q
  19513   "RTN","VPR EF",296,0)
  19514    S PRV=+$G (VPRLAST)
  19515   "RTN","VPR EF",297,0)
  19516    I PRV=0 S  PRV=.9
  19517   "RTN","VPR EF",298,0)
  19518    F  S PRV= $O(^VPROST ER(PRV)) Q :PRV'>0  D  ROS1(PRV)  I VPRMAX, VPRI'<VPRM AX Q
  19519   "RTN","VPR EF",299,0)
  19520    I PRV'>0  S VPRFINI= 1
  19521   "RTN","VPR EF",300,0)
  19522    Q
  19523   "RTN","VPR EF",301,0)
  19524    ;
  19525   "RTN","VPR EF",302,0)
  19526   ROS1(IEN)  ; -- get o ne roster
  19527   "RTN","VPR EF",303,0)
  19528    N ERRMSG
  19529   "RTN","VPR EF",304,0)
  19530    S ERRMSG= "A mumps e rror occur red while  extaractin g roster."
  19531   "RTN","VPR EF",305,0)
  19532    ;S ERRMSG =$$ERRMSG( "roster",I EN)
  19533   "RTN","VPR EF",306,0)
  19534    ;S $ET="D  ERRHDLR^V PRDERRH"
  19535   "RTN","VPR EF",307,0)
  19536    N VPRLIST ,VPRLIST2  ; these ge t defined  by VPRROS6
  19537   "RTN","VPR EF",308,0)
  19538    D GET^VPR ROS6(IEN)
  19539   "RTN","VPR EF",309,0)
  19540    N ROSTER, GBL,FLDS,R ESULT,VPRZ ,X,Y,VPRSE Q,VPRACT,V PRSOURCE,V PRV,NODE,V PRPAT,ID
  19541   "RTN","VPR EF",310,0)
  19542    K VPRV S  FLDS=".01: .06;1*;2;3 *;99",ID=I EN
  19543   "RTN","VPR EF",311,0)
  19544    D GETS^DI Q(561.2,IE N_",",FLDS ,"IEN","VP RV")
  19545   "RTN","VPR EF",312,0)
  19546    S Y=$NA(V PRV(561.2, IEN_","))
  19547   "RTN","VPR EF",313,0)
  19548    S ROSTER( "name")=$G (@Y@(.01," E"))
  19549   "RTN","VPR EF",314,0)
  19550    S ROSTER( "localId") =ID,ROSTER ("uid")=$$ SETUID^VPR UTILS("ros ter",,ID)
  19551   "RTN","VPR EF",315,0)
  19552    S X=$G(@Y @(99,"I"))  S:X ROSTE R("dateUpd ated")=$$J SONDT^VPRU TILS(X)
  19553   "RTN","VPR EF",316,0)
  19554    S X=$G(@Y @(.04,"I") ) S:X ROST ER("ownerL ocalId")=X ,ROSTER("o wnerUid")= $$SETUID^V PRUTILS("u ser",,X)
  19555   "RTN","VPR EF",317,0)
  19556    S X=$G(@Y @(.06,"E") ) S:X ROST ER("patien tListName" )=X
  19557   "RTN","VPR EF",318,0)
  19558    S X=$G(@Y @(.03,"I") ) S ROSTER ("disabled ")=$S(X=1: "true",1:" false")
  19559   "RTN","VPR EF",319,0)
  19560    S X=$G(@Y @(.05,"I") ) S ROSTER ("private" )=$S(X="PR ":"true",1 :"false")
  19561   "RTN","VPR EF",320,0)
  19562    S X=$G(@Y @(2,"E"))  S:X ROSTER ("specialH andling")= X
  19563   "RTN","VPR EF",321,0)
  19564    I $D(VPRV (561.21))  S NODE="", VPRZ=0 D
  19565   "RTN","VPR EF",322,0)
  19566    . F  S NO DE=$O(VPRV (561.21,NO DE)) Q:NOD E=""  D 
  19567   "RTN","VPR EF",323,0)
  19568    . . S VPR SEQ=VPRV(5 61.21,NODE ,.01,"I")  S ROSTER(" sources",V PRSEQ,"seq uence")=VP RSEQ
  19569   "RTN","VPR EF",324,0)
  19570    . . S VPR ACT=VPRV(5 61.21,NODE ,.03,"E")  S ROSTER(" sources",V PRSEQ,"act ion")=VPRA CT
  19571   "RTN","VPR EF",325,0)
  19572    . . S VPR SOURCE=VPR V(561.21,N ODE,.02,"I "),ROSTER( "sources", VPRSEQ,"so urce")=$$S OURCE(VPRS OURCE)
  19573   "RTN","VPR EF",326,0)
  19574    . . S ROS TER("sourc es",VPRSEQ ,"localId" )=+VPRSOUR CE
  19575   "RTN","VPR EF",327,0)
  19576    . . S GBL =U_$$CREF^ DILF($P(VP RSOURCE,"; ",2)) S RO STER("sour ces",VPRSE Q,"name")= $P($G(@GBL @(+VPRSOUR CE,0)),U)
  19577   "RTN","VPR EF",328,0)
  19578    I $D(VPRV (561.23))  S NODE="", VPRZ=0 D
  19579   "RTN","VPR EF",329,0)
  19580    . F  S NO DE=$O(VPRV (561.23,NO DE)) Q:NOD E=""  D
  19581   "RTN","VPR EF",330,0)
  19582    . . S VPR Z=VPRZ+1,V PRPAT=VPRV (561.23,NO DE,.01,"E" ),DFN=VPRV (561.23,NO DE,.01,"I" ),ICN=$$GE TICN^MPIF0 01(DFN)
  19583   "RTN","VPR EF",331,0)
  19584    . . S ROS TER("patie nts",VPRZ, "name")=VP RPAT,ROSTE R("patient s",VPRZ,"l ocalId")=D FN
  19585   "RTN","VPR EF",332,0)
  19586    . . S ROS TER("patie nts",VPRZ, "uid")=$$S ETUID^VPRU TILS("pati ent",DFN,D FN)
  19587   "RTN","VPR EF",333,0)
  19588    . . I $D( VPRV(561.2 3,NODE,.02 )) S ROSTE R("patient s",VPRZ,"s ourceSeque nce")=VPRV (561.23,NO DE,.02,"I" )
  19589   "RTN","VPR EF",334,0)
  19590    . . I ICN >0 S ROSTE R("patient s",VPRZ,"i cn")=ICN
  19591   "RTN","VPR EF",335,0)
  19592    . . S ROS TER("patie nts",VPRZ, "pid")=$$P ID^VPRDJFS (DFN)
  19593   "RTN","VPR EF",336,0)
  19594    D ADD("RO STER") S V PRLAST=ID
  19595   "RTN","VPR EF",337,0)
  19596    Q
  19597   "RTN","VPR EF",338,0)
  19598    ;
  19599   "RTN","VPR EF",339,0)
  19600   SOURCE(SRC ) ;
  19601   "RTN","VPR EF",340,0)
  19602    N X S X=" "
  19603   "RTN","VPR EF",341,0)
  19604    I SRC["SC ("         S X="clini c"
  19605   "RTN","VPR EF",342,0)
  19606    I SRC["DP T("        S X="patie nt"
  19607   "RTN","VPR EF",343,0)
  19608    I SRC["DI C(42"      S X="ward"
  19609   "RTN","VPR EF",344,0)
  19610    I SRC["SC TM"        S X="pcmm"
  19611   "RTN","VPR EF",345,0)
  19612    I SRC["OR (100.21"   S X="cprs"
  19613   "RTN","VPR EF",346,0)
  19614    I SRC["VP ROSTER"    S X="roste r"
  19615   "RTN","VPR EF",347,0)
  19616    I SRC["DI C(45.7"    S X="speci alty"
  19617   "RTN","VPR EF",348,0)
  19618    I SRC["VA (200"      S X="provi der"
  19619   "RTN","VPR EF",349,0)
  19620    I SRC["PX RM(810.4"  S X="pxrm"
  19621   "RTN","VPR EF",350,0)
  19622    Q X
  19623   "RTN","VPR EF",351,0)
  19624    ;
  19625   "RTN","VPR EF",352,0)
  19626   TESTROS ;  TEMPORARY  FOR TESTIN G
  19627   "RTN","VPR EF",353,0)
  19628    S FILT("d omain")="r oster"
  19629   "RTN","VPR EF",354,0)
  19630    S FILT("i d")=277
  19631   "RTN","VPR EF",355,0)
  19632    D GET^VPR EF(.ZZ,.FI LT)
  19633   "RTN","VPR EF",356,0)
  19634    Q
  19635   "RTN","VPR EF",357,0)
  19636    ;
  19637   "RTN","VPR EF",358,0)
  19638   ASU ; -- A SU files
  19639   "RTN","VPR EF",359,0)
  19640    N X,RTN S  X=$P($G(T YPE),"-",2 )
  19641   "RTN","VPR EF",360,0)
  19642    S RTN=$$U P^XLFSTR(X )_"^VPREAS U"
  19643   "RTN","VPR EF",361,0)
  19644    I X'="",$ L($T(@RTN) ) D @RTN
  19645   "RTN","VPR EF",362,0)
  19646    Q
  19647   "RTN","VPR EF",363,0)
  19648    ;
  19649   "RTN","VPR EF",364,0)
  19650   MDTERMS ;  -- CP Term inology
  19651   "RTN","VPR EF",365,0)
  19652    D:$L($T(T ERM^VPRMDU TL)) TERM^ VPRMDUTL
  19653   "RTN","VPR EF",366,0)
  19654    Q
  19655   "RTN","VPR EF",367,0)
  19656   LABGRP ;
  19657   "RTN","VPR EF",368,0)
  19658    D SHWCUMR 2^VPRELAB
  19659   "RTN","VPR EF",369,0)
  19660    Q
  19661   "RTN","VPR EF",370,0)
  19662   LABPNL ;
  19663   "RTN","VPR EF",371,0)
  19664    D SHWORPN L^VPRELAB
  19665   "RTN","VPR EF",372,0)
  19666    Q
  19667   "RTN","VPR EF",373,0)
  19668    ;
  19669   "RTN","VPR EF",374,0)
  19670   ISPROXY(IE N) ;
  19671   "RTN","VPR EF",375,0)
  19672    N APP
  19673   "RTN","VPR EF",376,0)
  19674    S APP=$O( ^VA(201,"B ","APPLICA TION PROXY ","")) I A PP'>0 Q 0
  19675   "RTN","VPR EF",377,0)
  19676    I $D(^VA( 200,IEN,"U SC3","B",A PP)) Q 1
  19677   "RTN","VPR EF",378,0)
  19678    Q 0
  19679   "RTN","VPR EFSG")
  19680   0^89^B7186 739
  19681   "RTN","VPR EFSG",1,0)
  19682   VPREFSG ;S LC/KCM --  GET for Ex tract and  Freshness  Stream
  19683   "RTN","VPR EFSG",2,0)
  19684    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  19685   "RTN","VPR EFSG",3,0)
  19686    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  19687   "RTN","VPR EFSG",4,0)
  19688    ;
  19689   "RTN","VPR EFSG",5,0)
  19690    ;
  19691   "RTN","VPR EFSG",6,0)
  19692   DOMITMS ;  loop thru  extract it ems, OFFSE T is last  sent
  19693   "RTN","VPR EFSG",7,0)
  19694    ; expects  VPRFSTRM, VPRFIDX,VP RFHMP
  19695   "RTN","VPR EFSG",8,0)
  19696    ; changes  VPRFSEQ,V PRFCNT as  each item  added
  19697   "RTN","VPR EFSG",9,0)
  19698    N X,OFFSE T,DOMAIN,T ASK,BATCH, TOTAL
  19699   "RTN","VPR EFSG",10,0 )
  19700    S X=^XTMP (VPRFSTRM, VPRFIDX)
  19701   "RTN","VPR EFSG",11,0 )
  19702    S X=$P(X, U,3),DOMAI N=$P(X,":" ),TASK=$P( X,":",2),T OTAL=$P(X, ":",4)
  19703   "RTN","VPR EFSG",12,0 )
  19704    S BATCH=" VPRFX~"_VP RFHMP_"~OP D"       ;  extract n ode in ^XT MP
  19705   "RTN","VPR EFSG",13,0 )
  19706    S OFFSET= TOTAL-(VPR FIDX-VPRFS EQ)
  19707   "RTN","VPR EFSG",14,0 )
  19708    F  S OFFS ET=$O(^XTM P(BATCH,TA SK,DOMAIN, OFFSET)) Q :'OFFSET   D  Q:VPRFC NT'<VPRFLI M
  19709   "RTN","VPR EFSG",15,0 )
  19710    . S VPRFC NT=VPRFCNT +1 ; incre ment the c ount of re turned ite ms
  19711   "RTN","VPR EFSG",16,0 )
  19712    . S VPRFS EQ=VPRFSEQ +1 ; incre ment the s equence nu mber in th e stream
  19713   "RTN","VPR EFSG",17,0 )
  19714    . M ^TMP( "VPRF",$J, VPRFCNT)=^ XTMP(BATCH ,TASK,DOMA IN,OFFSET)
  19715   "RTN","VPR EFSG",18,0 )
  19716    . I DOMAI N="patient " I $$PATI ENT(VPRFCN T,DOMAIN,$ G(TOTAL),O FFSET)=1 Q
  19717   "RTN","VPR EFSG",19,0 )
  19718    . S ^TMP( "VPRF",$J, VPRFCNT,.3 )=$$WRAPPE R(DOMAIN,$ S('TOTAL:0 ,1:OFFSET) ,+TOTAL)
  19719   "RTN","VPR EFSG",20,0 )
  19720    Q
  19721   "RTN","VPR EFSG",21,0 )
  19722    ;
  19723   "RTN","VPR EFSG",22,0 )
  19724   SYNCSTRT(S EQNODE) ;  Build sync Start obje ct with de mograhics
  19725   "RTN","VPR EFSG",23,0 )
  19726    S VPRFCNT =VPRFCNT+1
  19727   "RTN","VPR EFSG",24,0 )
  19728    S ^TMP("V PRF",$J,VP RFCNT,.3)= $$WRAPPER( "syncStart ",1,0)
  19729   "RTN","VPR EFSG",25,0 )
  19730    Q
  19731   "RTN","VPR EFSG",26,0 )
  19732   SYNCDONE(S EQNODE) ;  Build sync Status obj ect and st ick in ^TM P
  19733   "RTN","VPR EFSG",27,0 )
  19734    ;  expect s: VPRFSYS ,VPRFCNT
  19735   "RTN","VPR EFSG",28,0 )
  19736    N VPRBATC H,DFN,VPRB ATCH,STS,S TSJSON,X,E RR
  19737   "RTN","VPR EFSG",29,0 )
  19738    S VPRBATC H=$P(SEQNO DE,U,3) ;  VPRFX~hmpS rvId~dfn
  19739   "RTN","VPR EFSG",30,0 )
  19740    S STS("ui d")="urn:v a:syncStat us:"_VPRFS YS_":OPD"
  19741   "RTN","VPR EFSG",31,0 )
  19742    S STS("in itialized" )="true"
  19743   "RTN","VPR EFSG",32,0 )
  19744    S X="" F   S X=$O(^X TMP(VPRBAT CH,0,"coun t",X)) Q:' $L(X)  D
  19745   "RTN","VPR EFSG",33,0 )
  19746    . S STS(" domainTota ls",X)=^XT MP(VPRBATC H,0,"count ",X)
  19747   "RTN","VPR EFSG",34,0 )
  19748    D ENCODE^ VPRJSON("S TS","STSJS ON","ERR")
  19749   "RTN","VPR EFSG",35,0 )
  19750    I $D(ERR)  S $EC=",U JSON encod e error,"  Q
  19751   "RTN","VPR EFSG",36,0 )
  19752    S VPRFCNT =VPRFCNT+1
  19753   "RTN","VPR EFSG",37,0 )
  19754    M ^TMP("V PRF",$J,VP RFCNT)=STS JSON
  19755   "RTN","VPR EFSG",38,0 )
  19756    S ^TMP("V PRF",$J,VP RFCNT,.3)= $$WRAPPER( "syncStatu s","",-1)
  19757   "RTN","VPR EFSG",39,0 )
  19758    Q
  19759   "RTN","VPR EFSG",40,0 )
  19760    ;
  19761   "RTN","VPR EFSG",41,0 )
  19762   WRAPPER(DO MAIN,OFFSE T,TOTAL) ;  return JS ON wrapper  for each  item
  19763   "RTN","VPR EFSG",42,0 )
  19764    ; add obj ect tag if  extract t otal not z ero or if  total pass ed as -1
  19765   "RTN","VPR EFSG",43,0 )
  19766    ; seq and  total tag s only add ed if non- zero
  19767   "RTN","VPR EFSG",44,0 )
  19768    N X
  19769   "RTN","VPR EFSG",45,0 )
  19770    S X="},{" "collectio n"":"""_DO MAIN_""""
  19771   "RTN","VPR EFSG",46,0 )
  19772    I $G(OFFS ET)>0 S X= X_",""seq" ":"_OFFSET
  19773   "RTN","VPR EFSG",47,0 )
  19774    I $G(TOTA L)>0 S X=X _",""total "":"_TOTAL
  19775   "RTN","VPR EFSG",48,0 )
  19776    I $G(TOTA L) S X=X_" ,""object" ":"
  19777   "RTN","VPR EFSG",49,0 )
  19778    Q X
  19779   "RTN","VPR EFSG",50,0 )
  19780    ;
  19781   "RTN","VPR EFSG",51,0 )
  19782   PATIENT(VP RFCNT,DOMA IN,TOTAL,O FFSET) ;
  19783   "RTN","VPR EFSG",52,0 )
  19784    N DFN,PID S,TEMP,ERR OR,PTJSON
  19785   "RTN","VPR EFSG",53,0 )
  19786    M PTJSON= ^TMP("VPRF ",$J,VPRFC NT)
  19787   "RTN","VPR EFSG",54,0 )
  19788    K PTJSON( .3)
  19789   "RTN","VPR EFSG",55,0 )
  19790    D DECODE^ VPRJSON("P TJSON","TE MP","ERROR ")
  19791   "RTN","VPR EFSG",56,0 )
  19792    ;D DECODE ^VPRJSON($ NA(^TMP("V PRF",$J,VP RFCNT,1)), "TEMP","ER ROR")
  19793   "RTN","VPR EFSG",57,0 )
  19794    I '$D(TEM P) Q 0
  19795   "RTN","VPR EFSG",58,0 )
  19796    S DFN=TEM P("localId ") I DFN'> 0 Q 0
  19797   "RTN","VPR EFSG",59,0 )
  19798    S PIDS=$$ PIDS^VPRDJ FS(DFN)
  19799   "RTN","VPR EFSG",60,0 )
  19800    S ^TMP("V PRF",$J,VP RFCNT,.3)= $$WRAPPER^ VPRDJFSG(D OMAIN,PIDS ,$S('TOTAL :0,1:OFFSE T),+TOTAL)
  19801   "RTN","VPR EFSG",61,0 )
  19802    Q 1
  19803   "RTN","VPR EFSG",62,0 )
  19804    ;
  19805   "RTN","VPR EFSP")
  19806   0^90^B4485 8817
  19807   "RTN","VPR EFSP",1,0)
  19808   VPREFSP ;S LC/KCM --  PUT/POST f or Extract  and Fresh ness Strea m
  19809   "RTN","VPR EFSP",2,0)
  19810    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  19811   "RTN","VPR EFSP",3,0)
  19812    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  19813   "RTN","VPR EFSP",4,0)
  19814    ;
  19815   "RTN","VPR EFSP",5,0)
  19816    ;
  19817   "RTN","VPR EFSP",6,0)
  19818    ; --- cre ate a new  patient su bscription
  19819   "RTN","VPR EFSP",7,0)
  19820    ;
  19821   "RTN","VPR EFSP",8,0)
  19822   PUTSUB(ARG S,BODY) ;  return loc ation afte r creating  a new sub scription
  19823   "RTN","VPR EFSP",9,0)
  19824    ; PUT to:  /vpr/subs cription
  19825   "RTN","VPR EFSP",10,0 )
  19826    ;   JSON:  {server:h mpXYZ,loca lId:229,ic n:10232432 4,domains: [lab,med,. ..]}
  19827   "RTN","VPR EFSP",11,0 )
  19828    ;VPRFRSP:  location: /vpr/subsc ription/{h mpSrvId}/p atient/{df n}
  19829   "RTN","VPR EFSP",12,0 )
  19830    ;
  19831   "RTN","VPR EFSP",13,0 )
  19832    N CNT,DOM AIN,ICN,OB J,ERR,HMPS RV,VPRFDFN ,VPRFDOM,V PRBATCH,VP RFERR,NEWS UB
  19833   "RTN","VPR EFSP",14,0 )
  19834    D DECODE^ VPRJSON("B ODY","OBJ" ,"ERR")
  19835   "RTN","VPR EFSP",15,0 )
  19836    I $D(ERR)  D SETERR^ VPRDJFS("U nable to d ecode JSON ") Q ""
  19837   "RTN","VPR EFSP",16,0 )
  19838    S HMPSRV= $TR($G(OBJ ("server") ),"~","=")
  19839   "RTN","VPR EFSP",17,0 )
  19840    I '$L(HMP SRV) D SET ERR^VPRDJF S("Missing  HMP Serve r ID") Q " "
  19841   "RTN","VPR EFSP",18,0 )
  19842    M VPRFDOM =OBJ("doma ins") I $D (VPRFDOM)< 10 D DOMAI NS(.VPRFDO M)
  19843   "RTN","VPR EFSP",19,0 )
  19844    S VPRBATC H="VPRFX~" _HMPSRV_"~ OPD"
  19845   "RTN","VPR EFSP",20,0 )
  19846    ;;AGP che ck for dom ains alrea dy in proc ess, remov e domains  that alrea dy in proc ess.
  19847   "RTN","VPR EFSP",21,0 )
  19848    I $D(^XTM P(VPRBATCH ,0,"status ")) D
  19849   "RTN","VPR EFSP",22,0 )
  19850    .S CNT=0  F  S CNT=$ O(VPRFDOM( CNT)) Q:CN T'>0  D
  19851   "RTN","VPR EFSP",23,0 )
  19852    ..S DOMAI N=$G(VPRFD OM(CNT)) I  DOMAIN=""  Q
  19853   "RTN","VPR EFSP",24,0 )
  19854    ..I $G(^X TMP(VPRBAT CH,0,"stat us",DOMAIN ))=0 K VPR FDOM(CNT)
  19855   "RTN","VPR EFSP",25,0 )
  19856    ;
  19857   "RTN","VPR EFSP",26,0 )
  19858    I '$$TM^% ZTLOAD D S ETERR^VPRD JFS("Taskm an not run ning") Q " "
  19859   "RTN","VPR EFSP",27,0 )
  19860    I '$D(^XT MP("VPRFP" ,0)) D NEW XTMP^VPRDJ FS("VPRFP" ,9999,"VPR  Subscript ions")
  19861   "RTN","VPR EFSP",28,0 )
  19862    ;
  19863   "RTN","VPR EFSP",29,0 )
  19864    ; ^XTMP(" VPRFP",VPR FDFN,HMPSR V)=0 -- un subscribed
  19865   "RTN","VPR EFSP",30,0 )
  19866    ; ^XTMP(" VPRFP",VPR FDFN,HMPSR V)=1 -- su bscribed
  19867   "RTN","VPR EFSP",31,0 )
  19868    ; ^XTMP(" VPRFP",VPR FDFN,HMPSR V)=2 -- in itialized  (extracts  complete)
  19869   "RTN","VPR EFSP",32,0 )
  19870    ; locks e nsure only  one proce ss queues  the extrac ts
  19871   "RTN","VPR EFSP",33,0 )
  19872    S NEWSUB= 0
  19873   "RTN","VPR EFSP",34,0 )
  19874    ;
  19875   "RTN","VPR EFSP",35,0 )
  19876    L +^XTMP( "VPRFP","O PD",HMPSRV ):5 E  D S ETERR^VPRD JFS("Unabl e to lock  operationa l data for  "_DOMAIN)  Q
  19877   "RTN","VPR EFSP",36,0 )
  19878    ;I $G(^XT MP("VPRFP" ,DOMAIN,HM PSRV))'=1  S ^XTMP("V PRFP","OPD ",HMPSRV)= 1,NEWSUB=1
  19879   "RTN","VPR EFSP",37,0 )
  19880    S ^XTMP(" VPRFP","OP D",HMPSRV) =1,NEWSUB= 1
  19881   "RTN","VPR EFSP",38,0 )
  19882    L -^XTMP( "VPRFP","O PD",HMPSRV )
  19883   "RTN","VPR EFSP",39,0 )
  19884    I NEWSUB  D QUINIT(V PRBATCH,.V PRFDOM) Q: $G(VPRFERR ) ""
  19885   "RTN","VPR EFSP",40,0 )
  19886    Q "/vpr/s ubscriptio n/"_HMPSRV _"/operati onalData"
  19887   "RTN","VPR EFSP",41,0 )
  19888    ;
  19889   "RTN","VPR EFSP",42,0 )
  19890   QUINIT(VPR BATCH,VPRF DOM) ; Que ue the ini tial extra cts for a  patient
  19891   "RTN","VPR EFSP",43,0 )
  19892    ; VPRBATC H="VPRFP~h mpsrvid~OP D"  exampl e: VPRFX~h mpXYZ~229
  19893   "RTN","VPR EFSP",44,0 )
  19894    ; VPRFDOM (n)="domai nName"
  19895   "RTN","VPR EFSP",45,0 )
  19896    ; 
  19897   "RTN","VPR EFSP",46,0 )
  19898    ; ^XTMP(" VPRFX~hmps rvid~OPD", 0)=expires ^created^V PR Operati onal Data  Extract
  19899   "RTN","VPR EFSP",47,0 )
  19900    ;                             , 0,"status" ,domain)=e xtract sta tus
  19901   "RTN","VPR EFSP",48,0 )
  19902    ;                             , 0,"task",t askIen)=""
  19903   "RTN","VPR EFSP",49,0 )
  19904    ;                             , taskIen,do main,... ( extract da ta)
  19905   "RTN","VPR EFSP",50,0 )
  19906    ;
  19907   "RTN","VPR EFSP",51,0 )
  19908    D NEWXTMP ^VPRDJFS(V PRBATCH,1, "VPR Opera tional Dat a Extract" )
  19909   "RTN","VPR EFSP",52,0 )
  19910    S ^XTMP(V PRBATCH,0, "time")=$H
  19911   "RTN","VPR EFSP",53,0 )
  19912    N I S I=0  F  S I=$O (VPRFDOM(I )) Q:'I  D  SETDOM("s tatus",VPR FDOM(I),0)
  19913   "RTN","VPR EFSP",54,0 )
  19914    D SETMARK ("Start",V PRBATCH) ;  sends ful l demograp hics
  19915   "RTN","VPR EFSP",55,0 )
  19916    ;
  19917   "RTN","VPR EFSP",56,0 )
  19918    N ZTRTN,Z TDESC,ZTDT H,ZTIO,ZTU CI,ZTCPU,Z TPRI,ZTSAV E,ZTKIL,ZT SYNC,ZTSK
  19919   "RTN","VPR EFSP",57,0 )
  19920    S ZTRTN=" DQINIT^VPR EFSP",ZTIO ="",ZTDTH= $H
  19921   "RTN","VPR EFSP",58,0 )
  19922    S ZTSAVE( "VPRBATCH" )="",ZTSAV E("VPRFDOM (")=""
  19923   "RTN","VPR EFSP",59,0 )
  19924    S ZTDESC= "Build VPR  operation al data do mains"
  19925   "RTN","VPR EFSP",60,0 )
  19926    D ^%ZTLOA D
  19927   "RTN","VPR EFSP",61,0 )
  19928    ;D DQINIT
  19929   "RTN","VPR EFSP",62,0 )
  19930    ;
  19931   "RTN","VPR EFSP",63,0 )
  19932    I $G(ZTSK ) D
  19933   "RTN","VPR EFSP",64,0 )
  19934    .W !,"tas k: "_ZTSK
  19935   "RTN","VPR EFSP",65,0 )
  19936    .S ^XTMP( VPRBATCH,0 ,"task",ZT SK)="" I 1
  19937   "RTN","VPR EFSP",66,0 )
  19938    E  D SETE RR^VPRDJFS ("Task not  created")
  19939   "RTN","VPR EFSP",67,0 )
  19940    Q
  19941   "RTN","VPR EFSP",68,0 )
  19942   SETDOM(ATT RIB,DOMAIN ,VALUE) ;  Set value  for a doma in
  19943   "RTN","VPR EFSP",69,0 )
  19944    ; expects : VPRBATCH
  19945   "RTN","VPR EFSP",70,0 )
  19946    ; ATTRIB:  "status"  or "count"  attribute
  19947   "RTN","VPR EFSP",71,0 )
  19948    ; DOMAIN:  name of d omain
  19949   "RTN","VPR EFSP",72,0 )
  19950    ; if stat us, VALUE:  0=waiting , 1=ready
  19951   "RTN","VPR EFSP",73,0 )
  19952    ; if coun t,  VALUE:  count of  items
  19953   "RTN","VPR EFSP",74,0 )
  19954    S ^XTMP(V PRBATCH,0, ATTRIB,DOM AIN)=VALUE
  19955   "RTN","VPR EFSP",75,0 )
  19956    Q
  19957   "RTN","VPR EFSP",76,0 )
  19958   DQINIT ; D equeue ini tial extra cts
  19959   "RTN","VPR EFSP",77,0 )
  19960    ; expects :  VPRBATC H, VPRFDFN , VPRFDOM,  ZTSK
  19961   "RTN","VPR EFSP",78,0 )
  19962    I '$D(^XT MP(VPRBATC H,0,"task" ,ZTSK)) Q   ; extract  was super ceded
  19963   "RTN","VPR EFSP",79,0 )
  19964    N VPRFDOM I,VPRFSYS, VPRFZTSK
  19965   "RTN","VPR EFSP",80,0 )
  19966    S VPRFSYS =$$GET^XPA R("SYS","V PR SYSTEM  NAME")
  19967   "RTN","VPR EFSP",81,0 )
  19968    S VPRFZTS K=ZTSK ; j ust in cas e the unex pected hap pens to ZT SK
  19969   "RTN","VPR EFSP",82,0 )
  19970    S VPRFDOM I="" F  S  VPRFDOMI=$ O(VPRFDOM( VPRFDOMI))  Q:'VPRFDO MI  D
  19971   "RTN","VPR EFSP",83,0 )
  19972    . N FILTE R,RSLT
  19973   "RTN","VPR EFSP",84,0 )
  19974    . S FILTE R("domain" )=VPRFDOM( VPRFDOMI)
  19975   "RTN","VPR EFSP",85,0 )
  19976    . D GET^V PREF(.RSLT ,.FILTER)
  19977   "RTN","VPR EFSP",86,0 )
  19978    . D MOD4S TRM(VPRFDO M(VPRFDOMI ))
  19979   "RTN","VPR EFSP",87,0 )
  19980    . ; if su perceded,  stop proce ssing doma ins
  19981   "RTN","VPR EFSP",88,0 )
  19982    . I '$D(^ XTMP(VPRBA TCH,0,"tas k",VPRFZTS K)) S VPRF DOMI=999 Q
  19983   "RTN","VPR EFSP",89,0 )
  19984    . D SETDO M("status" ,VPRFDOM(V PRFDOMI),1 ) ; ready
  19985   "RTN","VPR EFSP",90,0 )
  19986    ; if supe rceded, re move extra cts produc ed by this  task
  19987   "RTN","VPR EFSP",91,0 )
  19988    I '$D(^XT MP(VPRBATC H,0,"task" ,VPRFZTSK) ) K ^XTMP( VPRBATCH,V PRFZTSK) Q
  19989   "RTN","VPR EFSP",92,0 )
  19990    ; don't a ssume init ialized, s ince we ma y split do mains to o ther tasks
  19991   "RTN","VPR EFSP",93,0 )
  19992    I $$INITD ONE(VPRBAT CH) D              ;  if all dom ains extra cted
  19993   "RTN","VPR EFSP",94,0 )
  19994    . D SETMA RK("Done", VPRBATCH)  ; - add up dated sync Status
  19995   "RTN","VPR EFSP",95,0 )
  19996    . D MVFRU PD(VPRBATC H)         ; - move f reshness u pdates ove r
  19997   "RTN","VPR EFSP",96,0 )
  19998    Q
  19999   "RTN","VPR EFSP",97,0 )
  20000   SETMARK(TY PE,VPRBATC H) ; Post  markers fo r begin an d end of i nitial syn ch
  20001   "RTN","VPR EFSP",98,0 )
  20002    N HPMSRV, NODES,X
  20003   "RTN","VPR EFSP",99,0 )
  20004    S HMPSRV= $P(VPRBATC H,"~",2)
  20005   "RTN","VPR EFSP",100, 0)
  20006    D POST^VP RDJFS("OPD ","sync"_T YPE,VPRBAT CH,"",HMPS RV,.NODES)
  20007   "RTN","VPR EFSP",101, 0)
  20008    Q:TYPE="S tart"
  20009   "RTN","VPR EFSP",102, 0)
  20010    S X="" F   S X=$O(NO DES(X)) Q: X=""  D  ;  iterate h mp servers
  20011   "RTN","VPR EFSP",103, 0)
  20012    . S ^XTMP ("VPRFP"," tidy",X,$P (NODES(X), U),$P(NODE S(X),U,2)) =VPRBATCH
  20013   "RTN","VPR EFSP",104, 0)
  20014    Q
  20015   "RTN","VPR EFSP",105, 0)
  20016   MVFRUPD(VP RBATCH) ;  Move fresh ness updat es over ac tive strea m
  20017   "RTN","VPR EFSP",106, 0)
  20018    N I,X,FRO M,HMPSRV,T YPE,ID,ACT
  20019   "RTN","VPR EFSP",107, 0)
  20020    S HMPSRV= $P(VPRBATC H,"~",2)
  20021   "RTN","VPR EFSP",108, 0)
  20022    S ^XTMP(" VPRFP","OP D",HMPSRV) =2       ;  now initi alized
  20023   "RTN","VPR EFSP",109, 0)
  20024    S FROM="V PRFH~"_HMP SRV_"~OPD"
  20025   "RTN","VPR EFSP",110, 0)
  20026    S I=0 F   S I=$O(^XT MP(FROM,I) ) Q:'I  D   ; move ov er held up dates
  20027   "RTN","VPR EFSP",111, 0)
  20028    . S X=^XT MP(FROM,I)
  20029   "RTN","VPR EFSP",112, 0)
  20030    . S TYPE= $P(X,U,2), ID=$P(X,U, 3),ACT=$P( X,U,4)
  20031   "RTN","VPR EFSP",113, 0)
  20032    . D POST^ VPRDJFS("O PD",TYPE,I D,ACT,HMPS RV)
  20033   "RTN","VPR EFSP",114, 0)
  20034    K ^XTMP(F ROM)
  20035   "RTN","VPR EFSP",115, 0)
  20036    Q
  20037   "RTN","VPR EFSP",116, 0)
  20038   MOD4STRM(D OMAIN) ; m odify extr act to be  ready for  stream
  20039   "RTN","VPR EFSP",117, 0)
  20040    ; expects : VPRBATCH , VPRFSYS,  VPRFZTSK
  20041   "RTN","VPR EFSP",118, 0)
  20042    ; results  are in ^X TMP("VPRFX ~hmpsrv~df n",DFN,DOM AIN,...)
  20043   "RTN","VPR EFSP",119, 0)
  20044    ; syncErr or: {uid,c ollection, error}  ui d=urn:va:s yncError:s ysId:dfn:e xtract
  20045   "RTN","VPR EFSP",120, 0)
  20046    N DFN,HMP SRV,COUNT, LNODE
  20047   "RTN","VPR EFSP",121, 0)
  20048    S HMPSRV= $P(VPRBATC H,"~",2)
  20049   "RTN","VPR EFSP",122, 0)
  20050    ; no item s -- COUNT  is in 1 n ode, other wise COUNT  is in the  .5 node
  20051   "RTN","VPR EFSP",123, 0)
  20052    S COUNT=0
  20053   "RTN","VPR EFSP",124, 0)
  20054    I $D(^XTM P(VPRBATCH ,VPRFZTSK, DOMAIN,.5) ) S COUNT= +$P(^(.5), """totalIt ems"":",2)
  20055   "RTN","VPR EFSP",125, 0)
  20056    ; remove  headers (. 5,.6) and  closing br aces (at C OUNT+1)
  20057   "RTN","VPR EFSP",126, 0)
  20058    K ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,.5)
  20059   "RTN","VPR EFSP",127, 0)
  20060    K ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,.6)
  20061   "RTN","VPR EFSP",128, 0)
  20062    K ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,COUNT+ 1)
  20063   "RTN","VPR EFSP",129, 0)
  20064    S LNODE=$ O(^XTMP(VP RBATCH,VPR FZTSK,DOMA IN,""),-1)
  20065   "RTN","VPR EFSP",130, 0)
  20066    I LNODE>0 ,$G(^XTMP( VPRBATCH,V PRFZTSK,DO MAIN,LNODE ))="]}}" K  ^XTMP(VPR BATCH,VPRF ZTSK,DOMAI N,LNODE)
  20067   "RTN","VPR EFSP",131, 0)
  20068    ; if no i tems -- re turn empty  object to  be wrappe d
  20069   "RTN","VPR EFSP",132, 0)
  20070    I COUNT=0  S ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,1,1)=" "
  20071   "RTN","VPR EFSP",133, 0)
  20072    ; if erro r, add syn cError obj ect (from  COUNT+2)
  20073   "RTN","VPR EFSP",134, 0)
  20074    I $D(^XTM P(VPRBATCH ,VPRFZTSK, DOMAIN,COU NT+2)) D
  20075   "RTN","VPR EFSP",135, 0)
  20076    . N JSON
  20077   "RTN","VPR EFSP",136, 0)
  20078    . D BLDSE RR(COUNT+2 ,DOMAIN,.J SON) Q:'$D (JSON)
  20079   "RTN","VPR EFSP",137, 0)
  20080    . S COUNT =COUNT+1
  20081   "RTN","VPR EFSP",138, 0)
  20082    . M ^XTMP (VPRBATCH, VPRFZTSK,D OMAIN,COUN T)=JSON
  20083   "RTN","VPR EFSP",139, 0)
  20084    ; set .7  node to to tal count  (including  error)
  20085   "RTN","VPR EFSP",140, 0)
  20086    ;S ^XTMP( VPRBATCH,V PRFZTSK,DO MAIN,.7)=C OUNT
  20087   "RTN","VPR EFSP",141, 0)
  20088    D SETDOM( "count",DO MAIN,COUNT )
  20089   "RTN","VPR EFSP",142, 0)
  20090    ; if coun t 0 -- sti ll return  wrapper ob ject so we  know the  domain had  nothing
  20091   "RTN","VPR EFSP",143, 0)
  20092    D POST^VP RDJFS("OPD ","syncDom ain",DOMAI N_":"_VPRF ZTSK_":"_( $S(COUNT=0 :1,1:COUNT ))_":"_COU NT,"",HMPS RV)
  20093   "RTN","VPR EFSP",144, 0)
  20094    Q
  20095   "RTN","VPR EFSP",145, 0)
  20096   BLDSERR(NO DE,DOMAIN, ERRJSON) ;  Create sy ncError ob ject in ER RJSON
  20097   "RTN","VPR EFSP",146, 0)
  20098    ; expects : VPRBATCH , VPRFSYS,  VPRFZTSK
  20099   "RTN","VPR EFSP",147, 0)
  20100    N ERRJSON ,ERROBJ,ER R,ERRMSG,S YNCERR
  20101   "RTN","VPR EFSP",148, 0)
  20102    S ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,NODE,. 3)="{"  ;  replace ,  with { for  decoding  JSON
  20103   "RTN","VPR EFSP",149, 0)
  20104    M ERRJSON =^XTMP(VPR BATCH,VPRF ZTSK,DOMAI N,NODE)
  20105   "RTN","VPR EFSP",150, 0)
  20106    D DECODE^ VPRJSON("E RRJSON","E RROBJ","ER R") I $D(E RR) S $EC= ",UJSON de code error ,"
  20107   "RTN","VPR EFSP",151, 0)
  20108    K ^XTMP(V PRBATCH,VP RFZTSK,DOM AIN,NODE)
  20109   "RTN","VPR EFSP",152, 0)
  20110    S ERRMSG= ERROBJ("er ror","mess age")
  20111   "RTN","VPR EFSP",153, 0)
  20112    Q:'$L(ERR MSG)
  20113   "RTN","VPR EFSP",154, 0)
  20114    S SYNCERR ("uid")="u rn:va:sync Error:"_VP RFSYS_":"_ DOMAIN
  20115   "RTN","VPR EFSP",155, 0)
  20116    S SYNCERR ("collecti on")=DOMAI N
  20117   "RTN","VPR EFSP",156, 0)
  20118    S SYNCERR ("error")= ERRMSG
  20119   "RTN","VPR EFSP",157, 0)
  20120    D ENCODE^ VPRJSON("S YNCERR","E RRJSON","E RR") I $D( ERR) S $EC =",UJSON e ncode erro r,"
  20121   "RTN","VPR EFSP",158, 0)
  20122    Q
  20123   "RTN","VPR EFSP",159, 0)
  20124   INITDONE(V PRBATCH) ;  Return 1  if all dom ains are d one
  20125   "RTN","VPR EFSP",160, 0)
  20126    N X,DONE
  20127   "RTN","VPR EFSP",161, 0)
  20128    S X="",DO NE=1
  20129   "RTN","VPR EFSP",162, 0)
  20130    F  S X=$O (^XTMP(VPR BATCH,0,"s tatus",X))  Q:'$L(X)   I '^(X) S  DONE=0
  20131   "RTN","VPR EFSP",163, 0)
  20132    Q DONE
  20133   "RTN","VPR EFSP",164, 0)
  20134    ;
  20135   "RTN","VPR EFSP",165, 0)
  20136   DOMAINS(LI ST) ; load  default d omains (pu t in param eter?)
  20137   "RTN","VPR EFSP",166, 0)
  20138    ;;asu-cla ss
  20139   "RTN","VPR EFSP",167, 0)
  20140    ;;asu-rul e
  20141   "RTN","VPR EFSP",168, 0)
  20142    ;;categor y
  20143   "RTN","VPR EFSP",169, 0)
  20144    ;;chartta b
  20145   "RTN","VPR EFSP",170, 0)
  20146    ;;display group
  20147   "RTN","VPR EFSP",171, 0)
  20148    ;;doc-def
  20149   "RTN","VPR EFSP",172, 0)
  20150    ;;labgrou p
  20151   "RTN","VPR EFSP",173, 0)
  20152    ;;labpane l
  20153   "RTN","VPR EFSP",174, 0)
  20154    ;;locatio n
  20155   "RTN","VPR EFSP",175, 0)
  20156    ;;orderab le
  20157   "RTN","VPR EFSP",176, 0)
  20158    ;;page
  20159   "RTN","VPR EFSP",177, 0)
  20160    ;;patient
  20161   "RTN","VPR EFSP",178, 0)
  20162    ;;personp hoto
  20163   "RTN","VPR EFSP",179, 0)
  20164    ;;pointof care
  20165   "RTN","VPR EFSP",180, 0)
  20166    ;;quick
  20167   "RTN","VPR EFSP",181, 0)
  20168    ;;roster
  20169   "RTN","VPR EFSP",182, 0)
  20170    ;;route
  20171   "RTN","VPR EFSP",183, 0)
  20172    ;;schedul e
  20173   "RTN","VPR EFSP",184, 0)
  20174    ;;team
  20175   "RTN","VPR EFSP",185, 0)
  20176    ;;teampos ition
  20177   "RTN","VPR EFSP",186, 0)
  20178    ;;user
  20179   "RTN","VPR EFSP",187, 0)
  20180    ;;usertab prefs
  20181   "RTN","VPR EFSP",188, 0)
  20182    ;;viewdef def
  20183   "RTN","VPR EFSP",189, 0)
  20184    ;;viewdef defcoldefc onfigtempl ate
  20185   "RTN","VPR EFSP",190, 0)
  20186    ;;zzzzz
  20187   "RTN","VPR EFSP",191, 0)
  20188    ;;clioter minology
  20189   "RTN","VPR EFSP",192, 0)
  20190    ;;doc-act ion
  20191   "RTN","VPR EFSP",193, 0)
  20192    ;;doc-sta tus
  20193   "RTN","VPR EFSP",194, 0)
  20194    N I,X
  20195   "RTN","VPR EFSP",195, 0)
  20196    F I=1:1 S  X=$P($T(D OMAINS+I), ";;",2,99)  Q:X="zzzz z"  S LIST (I)=X
  20197   "RTN","VPR EFSP",196, 0)
  20198    Q
  20199   "RTN","VPR EFSP",197, 0)
  20200    ;
  20201   "RTN","VPR EFST")
  20202   0^91^B5375 002
  20203   "RTN","VPR EFST",1,0)
  20204   VPREFST ;S LC/KCM --  Tests for  extract an d freshnes s stream
  20205   "RTN","VPR EFST",2,0)
  20206    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  20207   "RTN","VPR EFST",3,0)
  20208    ;
  20209   "RTN","VPR EFST",4,0)
  20210   TEST ; Tes t synchron ization pr ocess
  20211   "RTN","VPR EFST",5,0)
  20212    N LASTUPD ,TOTPTS,DO NE,START,G TOTAL
  20213   "RTN","VPR EFST",6,0)
  20214    S LASTUPD =0,TOTPTS= 0,DONE=0,G TOTAL=0
  20215   "RTN","VPR EFST",7,0)
  20216    S START=$ P($H,",",2 )
  20217   "RTN","VPR EFST",8,0)
  20218    ;D KILL^V PRDJFS
  20219   "RTN","VPR EFST",9,0)
  20220    D STRTSYN C
  20221   "RTN","VPR EFST",10,0 )
  20222    F  H 2 D  LOADUPD Q: DONE=1
  20223   "RTN","VPR EFST",11,0 )
  20224    ;D LOADUP D ; one la st time to  clear the  last pati ent
  20225   "RTN","VPR EFST",12,0 )
  20226    W !,"Elap sed Second s: ",$P($H ,",",2)-ST ART
  20227   "RTN","VPR EFST",13,0 )
  20228    Q
  20229   "RTN","VPR EFST",14,0 )
  20230   STRTSYNC ;  Add patie nts for sy nchronizat ion
  20231   "RTN","VPR EFST",15,0 )
  20232    ; expects  TOTPTS
  20233   "RTN","VPR EFST",16,0 )
  20234    N ARGS,RS P
  20235   "RTN","VPR EFST",17,0 )
  20236    S ARGS("c ommand")=" startOpera tionalData Extract"
  20237   "RTN","VPR EFST",18,0 )
  20238    S ARGS("s erver")="h mpTest"
  20239   "RTN","VPR EFST",19,0 )
  20240    D API^VPR DJFS(.RSP, .ARGS)
  20241   "RTN","VPR EFST",20,0 )
  20242    ;ZW ^TMP( "VPRF",$J)
  20243   "RTN","VPR EFST",21,0 )
  20244    Q
  20245   "RTN","VPR EFST",22,0 )
  20246   LOADUPD ;  Load updat es
  20247   "RTN","VPR EFST",23,0 )
  20248    ; expects  LASTUPD
  20249   "RTN","VPR EFST",24,0 )
  20250    N RSP,ARG S,ERR,CNT, LNODE
  20251   "RTN","VPR EFST",25,0 )
  20252    ;S ARGS(" command")= "getOperat ionalDataU pdates"
  20253   "RTN","VPR EFST",26,0 )
  20254    S ARGS("c ommand")=" getPtUpdat es"
  20255   "RTN","VPR EFST",27,0 )
  20256    S ARGS("s erver")="h mpTest"
  20257   "RTN","VPR EFST",28,0 )
  20258    S ARGS("l astUpdate" )=LASTUPD
  20259   "RTN","VPR EFST",29,0 )
  20260    S ARGS("m ax")=1000
  20261   "RTN","VPR EFST",30,0 )
  20262    D API^VPR DJFS(.RSP, .ARGS)
  20263   "RTN","VPR EFST",31,0 )
  20264    D SCANHDR S
  20265   "RTN","VPR EFST",32,0 )
  20266    S LASTUPD =$$GETLUPD
  20267   "RTN","VPR EFST",33,0 )
  20268    S CNT=$$C NTOBJS,GTO TAL=GTOTAL +CNT
  20269   "RTN","VPR EFST",34,0 )
  20270    W !,"last Update: ", LASTUPD,"   items: ", CNT_"/"_GT OTAL,?50
  20271   "RTN","VPR EFST",35,0 )
  20272    Q
  20273   "RTN","VPR EFST",36,0 )
  20274   SCANHDRS ;  Scan head ers for sy ncDone obj ects
  20275   "RTN","VPR EFST",37,0 )
  20276    ; expects  DONEPTS
  20277   "RTN","VPR EFST",38,0 )
  20278    N I
  20279   "RTN","VPR EFST",39,0 )
  20280    W !
  20281   "RTN","VPR EFST",40,0 )
  20282    ;ZW ^TMP( "VPRF",$J)
  20283   "RTN","VPR EFST",41,0 )
  20284    S I=0 F   S I=$O(^TM P("VPRF",$ J,I)) Q:'I   D
  20285   "RTN","VPR EFST",42,0 )
  20286    . I $G(^T MP("VPRF", $J,I,.3))[ "syncStatu s" S DONE= 1
  20287   "RTN","VPR EFST",43,0 )
  20288    Q
  20289   "RTN","VPR EFST",44,0 )
  20290   SHOWHDRS ;  Show obje ct header  info
  20291   "RTN","VPR EFST",45,0 )
  20292    N I
  20293   "RTN","VPR EFST",46,0 )
  20294    S I=0 F   S I=$O(^TM P("VPRF",$ J,I)) Q:'I   D
  20295   "RTN","VPR EFST",47,0 )
  20296    . W !,"Hd r: ",$G(^T MP("VPRF", $J,I,.3))
  20297   "RTN","VPR EFST",48,0 )
  20298    Q
  20299   "RTN","VPR EFST",49,0 )
  20300   CNTOBJS()  ; Return c ount of ob jects retu rned
  20301   "RTN","VPR EFST",50,0 )
  20302    N I,C
  20303   "RTN","VPR EFST",51,0 )
  20304    S C=0
  20305   "RTN","VPR EFST",52,0 )
  20306    S I=.9 ;  skip .5 he ader node
  20307   "RTN","VPR EFST",53,0 )
  20308    W !
  20309   "RTN","VPR EFST",54,0 )
  20310    ;ZW ^TMP( "VPRF",$J)
  20311   "RTN","VPR EFST",55,0 )
  20312    F  S I=$O (^TMP("VPR F",$J,I))  Q:'I  I $L ($G(^TMP(" VPRF",$J,I ,1))) S C= C+1 W !,^T MP("VPRF", $J,I,1)
  20313   "RTN","VPR EFST",56,0 )
  20314    Q C
  20315   "RTN","VPR EFST",57,0 )
  20316    ;
  20317   "RTN","VPR EFST",58,0 )
  20318   GETLUPD()  ; Return l ast update  value
  20319   "RTN","VPR EFST",59,0 )
  20320    N X
  20321   "RTN","VPR EFST",60,0 )
  20322    W !
  20323   "RTN","VPR EFST",61,0 )
  20324    ;ZW ^TMP( "VPRF",$J)
  20325   "RTN","VPR EFST",62,0 )
  20326    S X=^TMP( "VPRF",$J, .5),X=$P(X ,"""lastUp date"":""" ,2),X=$P(X ,""",")
  20327   "RTN","VPR EFST",63,0 )
  20328    Q X
  20329   "RTN","VPR EFST",64,0 )
  20330    ;
  20331   "RTN","VPR EFST",65,0 )
  20332   TOTALS ;
  20333   "RTN","VPR EFST",66,0 )
  20334    N P,T
  20335   "RTN","VPR EFST",67,0 )
  20336    S T=0
  20337   "RTN","VPR EFST",68,0 )
  20338    S P=0 F   S P=$O(^XT MP("VPRFP" ,P)) Q:'P   S T=T+^XT MP("VPRFP" ,P,"hmpTes t","total" )
  20339   "RTN","VPR EFST",69,0 )
  20340    W !,"TOTA L: ",T
  20341   "RTN","VPR EFST",70,0 )
  20342    Q
  20343   "RTN","VPR EFST",71,0 )
  20344   GETFEW ;
  20345   "RTN","VPR EFST",72,0 )
  20346    S ARGS("c ommand")=" getPtUpdat es"
  20347   "RTN","VPR EFST",73,0 )
  20348    S ARGS("s erver")="h mpTest"
  20349   "RTN","VPR EFST",74,0 )
  20350    S ARGS("l astUpdate" )="3140115 -251"
  20351   "RTN","VPR EFST",75,0 )
  20352    S ARGS("m ax")=10
  20353   "RTN","VPR EFST",76,0 )
  20354    D API^VPR DJFS(.RSP, .ARGS)
  20355   "RTN","VPR EFST",77,0 )
  20356    Q
  20357   "RTN","VPR EFX")
  20358   0^55^B8552 882
  20359   "RTN","VPR EFX",1,0)
  20360   VPREFX ;SL C/MKB -- R eference d ata update  ; 7/19/12  2:26pm
  20361   "RTN","VPR EFX",2,0)
  20362    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  20363   "RTN","VPR EFX",3,0)
  20364    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  20365   "RTN","VPR EFX",4,0)
  20366    ;
  20367   "RTN","VPR EFX",5,0)
  20368    ; Externa l Referenc es           DBIA#
  20369   "RTN","VPR EFX",6,0)
  20370    ; ------- ---------- --           -----
  20371   "RTN","VPR EFX",7,0)
  20372    ; ^DPT                            10035
  20373   "RTN","VPR EFX",8,0)
  20374    ; MPIF001                          2701
  20375   "RTN","VPR EFX",9,0)
  20376    ; XLFSTR                          10104
  20377   "RTN","VPR EFX",10,0)
  20378    ;
  20379   "RTN","VPR EFX",11,0)
  20380   EN(LAST,MA X) ; -- ge t data fro m ^XTMP("V PREF-<date >",n)
  20381   "RTN","VPR EFX",12,0)
  20382    ;[MAX not  used yet]
  20383   "RTN","VPR EFX",13,0)
  20384    N X,Y,VPR TOTL,DOMCN T,TYPE,NAM E,RTN,VPRI D
  20385   "RTN","VPR EFX",14,0)
  20386    S LAST=$G (LAST) D G ETLIST(LAS T)
  20387   "RTN","VPR EFX",15,0)
  20388    G ENQ:$G( ^TMP("VPRX ",$J,0))<1  ;no data
  20389   "RTN","VPR EFX",16,0)
  20390    ;
  20391   "RTN","VPR EFX",17,0)
  20392    S (VPRTOT L,DOMCNT)= 0
  20393   "RTN","VPR EFX",18,0)
  20394    S TYPE=""  F  S TYPE =$O(^TMP(" VPRX",$J,T YPE)) Q:TY PE=""  D
  20395   "RTN","VPR EFX",19,0)
  20396    . S NAME= $$LOW^XLFS TR(TYPE)
  20397   "RTN","VPR EFX",20,0)
  20398    . S RTN=$ $TAG^VPREF (NAME)_"^V PREF" Q:'$ L($T(@RTN) )
  20399   "RTN","VPR EFX",21,0)
  20400    . S DOMCN T=DOMCNT+1
  20401   "RTN","VPR EFX",22,0)
  20402    . ;
  20403   "RTN","VPR EFX",23,0)
  20404    . N VPR,V PRI
  20405   "RTN","VPR EFX",24,0)
  20406    . S VPR=$ NA(^TMP("V PR",$J,DOM CNT)),VPRI =0,VPRID=" "
  20407   "RTN","VPR EFX",25,0)
  20408    . F  S VP RID=$O(^TM P("VPRX",$ J,TYPE,VPR ID)) Q:VPR ID=""  D
  20409   "RTN","VPR EFX",26,0)
  20410    .. D @RTN  S VPRTOTL =VPRTOTL+1
  20411   "RTN","VPR EFX",27,0)
  20412    . ;
  20413   "RTN","VPR EFX",28,0)
  20414    . I 'VPRI  S DOMCNT= DOMCNT-1 Q    ;no dat a, or erro r
  20415   "RTN","VPR EFX",29,0)
  20416    . S:DOMCN T>1 @VPR@( .3)=","
  20417   "RTN","VPR EFX",30,0)
  20418    . S @VPR@ (.5)="{""d omainName" ":"""_NAME _""",""tot al"":"_VPR I_",""item s"":["
  20419   "RTN","VPR EFX",31,0)
  20420    . S VPRI= VPRI+1,@VP R@(VPRI)=" ]}"
  20421   "RTN","VPR EFX",32,0)
  20422    ;
  20423   "RTN","VPR EFX",33,0)
  20424   ENQ ;
  20425   "RTN","VPR EFX",34,0)
  20426    S Y=$G(^T MP("VPRX", $J,0)) K ^ TMP("VPRX" ,$J)
  20427   "RTN","VPR EFX",35,0)
  20428    I '$G(DOM CNT) S @VP R@(.5)="{" "apiVersio n"":""1.01 "",""data" ":{""lastU pdate"":"" "_LAST_""" ,""totalIt ems"":0,"" items"":[] }}" Q
  20429   "RTN","VPR EFX",36,0)
  20430    ;
  20431   "RTN","VPR EFX",37,0)
  20432    S @VPR@(. 5)="{""api Version"": ""1.01""," "data"":{" "lastUpdat e"":"""_Y_ """,""tota lItems"":" _DOMCNT_", ""items"": ["
  20433   "RTN","VPR EFX",38,0)
  20434    S VPRI=DO MCNT I $D( ^TMP($J,"V PR ERROR") ) D
  20435   "RTN","VPR EFX",39,0)
  20436    . N ERROR ,CNT
  20437   "RTN","VPR EFX",40,0)
  20438    . D BUILD ERR^VPREF( .ERROR)
  20439   "RTN","VPR EFX",41,0)
  20440    . S VPRI= VPRI+1,@VP R@(VPRI)=" ,",CNT=0
  20441   "RTN","VPR EFX",42,0)
  20442    . F  S CN T=$O(ERROR (CNT)) Q:C NT'>0  S V PRI=VPRI+1 ,@VPR@(VPR I)=ERROR(C NT)
  20443   "RTN","VPR EFX",43,0)
  20444    . K ^TMP( $J,"VPR ER ROR")
  20445   "RTN","VPR EFX",44,0)
  20446    S VPRI=VP RI+1,@VPR@ (VPRI)="]} }"
  20447   "RTN","VPR EFX",45,0)
  20448    Q
  20449   "RTN","VPR EFX",46,0)
  20450    ;
  20451   "RTN","VPR EFX",47,0)
  20452   GETLIST(LA ST) ; -- b uild list  of updates  for clien t
  20453   "RTN","VPR EFX",48,0)
  20454    ; Returns  ^TMP("VPR X",$J,0) =  last DATE :SEQ inclu ded
  20455   "RTN","VPR EFX",49,0)
  20456    ;          ^TMP("VPR X",$J,TYPE ,ID)=ACT
  20457   "RTN","VPR EFX",50,0)
  20458    N DATE,SE Q,BEG,END, IDX,X0,DFN ,TYPE,ID,A CT
  20459   "RTN","VPR EFX",51,0)
  20460    K ^TMP("V PRX",$J)
  20461   "RTN","VPR EFX",52,0)
  20462    S DATE=+L AST,SEQ=+$ P(LAST,":" ,2)
  20463   "RTN","VPR EFX",53,0)
  20464    ; generat e list ID,  and end p oint
  20465   "RTN","VPR EFX",54,0)
  20466    S BEG=$NA (^XTMP("VP REF-"_DATE ,SEQ))          ;init  loop wher e left off
  20467   "RTN","VPR EFX",55,0)
  20468    ; END=$Q( ^XTMP("VPR EF-"_(DT+1 ),9999999) ,-1) ;last  node
  20469   "RTN","VPR EFX",56,0)
  20470    S END=+$O (^XTMP("VP REF-"_DT," A"),-1)         ;last  node
  20471   "RTN","VPR EFX",57,0)
  20472    S ^TMP("V PRX",$J,0) =DT_":"_EN D               ;date :seq
  20473   "RTN","VPR EFX",58,0)
  20474    ;
  20475   "RTN","VPR EFX",59,0)
  20476    S IDX=BEG  F  S IDX= $Q(@IDX) Q :$$DONE  D
  20477   "RTN","VPR EFX",60,0)
  20478    . S X0=@I DX,TYPE=$P (X0,U),ID= $P(X0,U,2) ,ACT=$P(X0 ,U,3)
  20479   "RTN","VPR EFX",61,0)
  20480    . I TYPE= ""!(ID="")  Q  ;error
  20481   "RTN","VPR EFX",62,0)
  20482    . S ^TMP( "VPRX",$J, TYPE,ID)=A CT
  20483   "RTN","VPR EFX",63,0)
  20484    Q
  20485   "RTN","VPR EFX",64,0)
  20486    ;
  20487   "RTN","VPR EFX",65,0)
  20488   DONE() ; - - Return 1  or 0, if  loop has f inished
  20489   "RTN","VPR EFX",66,0)
  20490    I IDX'?1" ^XTMP(""VP REF-"7N.E   Q 1  ;end  of ^XTMP
  20491   "RTN","VPR EFX",67,0)
  20492    N D,N S D =+$P(IDX," -",2),N=+$ P(IDX,",", 2)
  20493   "RTN","VPR EFX",68,0)
  20494    ; check V PR-DATE su bscript
  20495   "RTN","VPR EFX",69,0)
  20496    I D<DT Q  0                           ;pri or day: ke ep going
  20497   "RTN","VPR EFX",70,0)
  20498    I D>DT Q  1                           ;nex t day:  st op loop
  20499   "RTN","VPR EFX",71,0)
  20500    ; D=DT: c heck seque nce# subsc ript
  20501   "RTN","VPR EFX",72,0)
  20502    I N>END Q  1
  20503   "RTN","VPR EFX",73,0)
  20504    Q 0
  20505   "RTN","VPR EHL7")
  20506   0^97^B3241 775
  20507   "RTN","VPR EHL7",1,0)
  20508   VPREHL7 ;A LB/MJK - V PR HL7 ADT  Message P rocessor ; 03/25/2014  16:50:09
  20509   "RTN","VPR EHL7",2,0)
  20510    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  20511   "RTN","VPR EHL7",3,0)
  20512    ;;
  20513   "RTN","VPR EHL7",4,0)
  20514    ;
  20515   "RTN","VPR EHL7",5,0)
  20516   ADT ; -- m ain entry  point for  the follow ing VPR AD T client/r outer prot ocols:
  20517   "RTN","VPR EHL7",6,0)
  20518    ;           - VPR AD T-A04 CLIE NT protoco l
  20519   "RTN","VPR EHL7",7,0)
  20520    ;              o  su bscribes t o VAFC ADT -A04 SERVE
  20521   "RTN","VPR EHL7",8,0)
  20522    ;           - VPR AD T-A08 CLIE NT protoco l
  20523   "RTN","VPR EHL7",9,0)
  20524    ;              o  su bscribes t o VAFC ADT -A08 SERVE
  20525   "RTN","VPR EHL7",10,0 )
  20526    ;
  20527   "RTN","VPR EHL7",11,0 )
  20528    ; Note: T hese varia bles are p rovided by  the VistA  HL7 syste m when a
  20529   "RTN","VPR EHL7",12,0 )
  20530    ;       s ubscriber  protocol's  ROUTING L OGIC is ca lled:
  20531   "RTN","VPR EHL7",13,0 )
  20532    ;             - HLNE XT
  20533   "RTN","VPR EHL7",14,0 )
  20534    ;             - HLQU IT
  20535   "RTN","VPR EHL7",15,0 )
  20536    ;             - HLNO DE
  20537   "RTN","VPR EHL7",16,0 )
  20538    ;             - HL(" FS")
  20539   "RTN","VPR EHL7",17,0 )
  20540    ;             - HL(" ECH")
  20541   "RTN","VPR EHL7",18,0 )
  20542    ;
  20543   "RTN","VPR EHL7",19,0 )
  20544    ; -- scan s/filters  ADT/A04 &  A08 events  for PID s egment and  DFN; sets  ^XTMP("VP RFS~...
  20545   "RTN","VPR EHL7",20,0 )
  20546    ;
  20547   "RTN","VPR EHL7",21,0 )
  20548    NEW DONE, VPRSEG,VPR EVT
  20549   "RTN","VPR EHL7",22,0 )
  20550    SET DONE= 0
  20551   "RTN","VPR EHL7",23,0 )
  20552    FOR  XECU TE HLNEXT  QUIT:HLQUI T'>0  DO   QUIT:DONE
  20553   "RTN","VPR EHL7",24,0 )
  20554    . SET VPR SEG=$EXTRA CT(HLNODE, 1,3)
  20555   "RTN","VPR EHL7",25,0 )
  20556    . ;
  20557   "RTN","VPR EHL7",26,0 )
  20558    . IF VPRS EG="EVN" D O  QUIT
  20559   "RTN","VPR EHL7",27,0 )
  20560    . . SET V PREVT=$PIE CE(HLNODE, HLFS,2)
  20561   "RTN","VPR EHL7",28,0 )
  20562    . . IF VP REVT="A04"  QUIT
  20563   "RTN","VPR EHL7",29,0 )
  20564    . . ; --  97 reason  = sensitiv e patient  change occ urred
  20565   "RTN","VPR EHL7",30,0 )
  20566    . . IF VP REVT="A08" ,$PIECE(HL NODE,HLFS, 5)=97 QUIT
  20567   "RTN","VPR EHL7",31,0 )
  20568    . . ; --  not an eve nt VPR is  interested  in so don e with mes sage
  20569   "RTN","VPR EHL7",32,0 )
  20570    . . SET D ONE=1
  20571   "RTN","VPR EHL7",33,0 )
  20572    . ; -- PI D segment  always com es after E VN segment
  20573   "RTN","VPR EHL7",34,0 )
  20574    . IF VPRS EG'="PID"  QUIT
  20575   "RTN","VPR EHL7",35,0 )
  20576    . SET DON E=1
  20577   "RTN","VPR EHL7",36,0 )
  20578    . ; -- VP REVT shoul d always b e defined  at this po int
  20579   "RTN","VPR EHL7",37,0 )
  20580    . IF $G(V PREVT)=""  QUIT
  20581   "RTN","VPR EHL7",38,0 )
  20582    . NEW DFN
  20583   "RTN","VPR EHL7",39,0 )
  20584    . SET DFN =+$PIECE($ PIECE(HLNO DE,HL("FS" ),4),$EXTR ACT(HL("EC H")))
  20585   "RTN","VPR EHL7",40,0 )
  20586    . IF 'DFN  QUIT
  20587   "RTN","VPR EHL7",41,0 )
  20588    . DO POST X^VPREVNT( "pt-select ",DFN_"&"_ VPREVT)  ; Ref File e vent
  20589   "RTN","VPR EHL7",42,0 )
  20590    . IF $DAT A(^VPR(560 ,"AITEM",D FN)) DO PO ST^VPREVNT (DFN,"pati ent",DFN)
  20591   "RTN","VPR EHL7",43,0 )
  20592    QUIT
  20593   "RTN","VPR EHL7",44,0 )
  20594    ;
  20595   "RTN","VPR ELAB")
  20596   0^84^B5640 555
  20597   "RTN","VPR ELAB",1,0)
  20598   VPRELAB ;  SLC/JMC -  Lab extrac t utilitie s ; 2/20/1 4 4:23pm
  20599   "RTN","VPR ELAB",2,0)
  20600    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 1913;B uild 283
  20601   "RTN","VPR ELAB",3,0)
  20602   SHWORPNL ;  Ordering  panels (en ds in "pan el")
  20603   "RTN","VPR ELAB",4,0)
  20604    N X,COUNT ,LABDAT
  20605   "RTN","VPR ELAB",5,0)
  20606    S X=$NA(^ LAB(60))
  20607   "RTN","VPR ELAB",6,0)
  20608    F  S X=$Q (@X) Q:($Q S(X,1)'=60 )!($QS(X,2 )'=+$QS(X, 2))  D
  20609   "RTN","VPR ELAB",7,0)
  20610    . I $QS(X ,3)=0  D
  20611   "RTN","VPR ELAB",8,0)
  20612    . . I $D( LABDAT),CO UNT>0 S VP RCNT=VPRCN T+1 D ADD^ VPREF("LAB DAT") K LA BDAT
  20613   "RTN","VPR ELAB",9,0)
  20614    . . S COU NT=0,LABDA T("name")= $P(@X,"^", 1),LABDAT( "uid")=$$S ETUID^VPRU TILS("labp anel","",$ QS(X,2))
  20615   "RTN","VPR ELAB",10,0 )
  20616    . I $QS(X ,3)=2,$QS( X,4)>0  D
  20617   "RTN","VPR ELAB",11,0 )
  20618    . . S LAB DAT("labs" ,$QS(X,4), "id")=@X,L ABDAT("lab s",$QS(X,4 ),"name")= $P(^LAB(60 ,+@X,0),"^ ",1),COUNT =COUNT+1
  20619   "RTN","VPR ELAB",12,0 )
  20620    I $D(LABD AT),COUNT> 0 S VPRCNT =VPRCNT+1  D ADD^VPRE F("LABDAT" ) K LABDAT
  20621   "RTN","VPR ELAB",13,0 )
  20622    S VPRFINI =1
  20623   "RTN","VPR ELAB",14,0 )
  20624    Q
  20625   "RTN","VPR ELAB",15,0 )
  20626   SHWCUMR2 ;  All Cumul ative Repo rts and th e labs the y point to  (for UI p ick on lab s view)
  20627   "RTN","VPR ELAB",16,0 )
  20628    N X,LASTS UB,LASTLAB ,LABDAT
  20629   "RTN","VPR ELAB",17,0 )
  20630    S LASTSUB =0,LASTLAB =0,X=$NA(^ LAB(64.5,1 ,1))
  20631   "RTN","VPR ELAB",18,0 )
  20632    F  S X=$Q (@X) Q:($Q S(X,4)="B" )!($QS(X,3 )'=1)!($QS (X,2)'=1)! ($QS(X,1)' =64.5)  D
  20633   "RTN","VPR ELAB",19,0 )
  20634    . I $QS(X ,5)=0  D
  20635   "RTN","VPR ELAB",20,0 )
  20636    . . I $D( LABDAT) S  VPRCNT=VPR CNT+1 D AD D^VPREF("L ABDAT") K  LABDAT
  20637   "RTN","VPR ELAB",21,0 )
  20638    . . S LAS TSUB=0,LAS TLAB=0,LAB DAT("name" )=$P(@X,"^ ",1)
  20639   "RTN","VPR ELAB",22,0 )
  20640    . I $QS(X ,7)=0 S LA STSUB=LAST SUB+1,LAST LAB=0,LABD AT("uid")= $$SETUID^V PRUTILS("l abgroup",, $QS(X,4)), LABDAT("gr oups",LAST SUB,"name" )=$P(@X,"^ ",1)
  20641   "RTN","VPR ELAB",23,0 )
  20642    . I $QS(X ,9)=0  D
  20643   "RTN","VPR ELAB",24,0 )
  20644    . . S LAS TLAB=LASTL AB+1
  20645   "RTN","VPR ELAB",25,0 )
  20646    . . S LAB DAT("group s",LASTSUB ,"labs",LA STLAB,"nam e")=$P(^LA B(60,$P(@X ,"^",1),0) ,"^",1)
  20647   "RTN","VPR ELAB",26,0 )
  20648    . . S LAB DAT("group s",LASTSUB ,"labs",LA STLAB,"id" )=$P(@X,"^ ",1)
  20649   "RTN","VPR ELAB",27,0 )
  20650    I $D(LABD AT) S VPRC NT=VPRCNT+ 1 D ADD^VP REF("LABDA T") K LABD AT
  20651   "RTN","VPR ELAB",28,0 )
  20652    S VPRFINI =1
  20653   "RTN","VPR ELAB",29,0 )
  20654    Q
  20655   "RTN","VPR ELAB",30,0 )
  20656   LABPNL ; L ab orderin g panels
  20657   "RTN","VPR ELAB",31,0 )
  20658    ; {name:p anelName,u id:panelUi d,labs:[{i d:labIEN,n ame:labNam e},...]}
  20659   "RTN","VPR ELAB",32,0 )
  20660    N IEN
  20661   "RTN","VPR ELAB",33,0 )
  20662    F  S IEN= $O(^LAB(60 ,IEN)) Q:' IEN  D
  20663   "RTN","VPR ELAB",34,0 )
  20664    . N X0,LA B
  20665   "RTN","VPR ELAB",35,0 )
  20666    . S X0=$G (^LAB(60,I EN,0))
  20667   "RTN","VPR ELAB",36,0 )
  20668    . Q:"IB"' [$P(X0,U,3 )       ;  not for or dering
  20669   "RTN","VPR ELAB",37,0 )
  20670    . Q:'$O(^ LAB(60,IEN ,2,0))  ;  not panel
  20671   "RTN","VPR ELAB",38,0 )
  20672    . S LAB(" name")=$P( X0,U)
  20673   "RTN","VPR ELAB",39,0 )
  20674    . S LAB(" uid")=$$SE TUID^VPRUT ILS("labpa nel","",IE N)
  20675   "RTN","VPR ELAB",40,0 )
  20676    . ; recur sively exp and to ind ividual te sts
  20677   "RTN","VPR ELAB",41,0 )
  20678    . D ADD^V PREF("LAB" )
  20679   "RTN","VPR ELAB",42,0 )
  20680    I 'IEN S  VPRFINI=1
  20681   "RTN","VPR ELAB",43,0 )
  20682    Q
  20683   "RTN","VPR ELAB",44,0 )
  20684   LABGRP ; L ab groups  on cumulat ive report
  20685   "RTN","VPR ELAB",45,0 )
  20686    ; {name:g roupName,u id:groupUi d,labs:[{n ame:labNam e,id:labIE N},...]}
  20687   "RTN","VPR ELAB",46,0 )
  20688    F  S IEN= $O(^LAB(60 ,IEN)) Q:' IEN  D
  20689   "RTN","VPR ELAB",47,0 )
  20690    . Q
  20691   "RTN","VPR ELAB",48,0 )
  20692    Q
  20693   "RTN","VPR ENSZ")
  20694   0^56^B6859 4142
  20695   "RTN","VPR ENSZ",1,0)
  20696   VPRENSZ ;S LC/KCM - M easure dat a sizes
  20697   "RTN","VPR ENSZ",2,0)
  20698    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  20699   "RTN","VPR ENSZ",3,0)
  20700    ;
  20701   "RTN","VPR ENSZ",4,0)
  20702   EN ; Find  Max, Mean,  Median fo r each TAG
  20703   "RTN","VPR ENSZ",5,0)
  20704    K ^XTMP(" VPRENSZ-DO MAINS")
  20705   "RTN","VPR ENSZ",6,0)
  20706    D ALG,PRB ,DOC,ENC,A CC,LAB,MIC ,RAD,VIT,R XI,RXO,NVA ,ORD,OBS
  20707   "RTN","VPR ENSZ",7,0)
  20708    Q
  20709   "RTN","VPR ENSZ",8,0)
  20710   ALG ;@type  ALLERGY @ name Aller gies
  20711   "RTN","VPR ENSZ",9,0)
  20712    D REPORT( 120.8,"ALG ")
  20713   "RTN","VPR ENSZ",10,0 )
  20714    Q
  20715   "RTN","VPR ENSZ",11,0 )
  20716   PRB ;@type  PROBLEM @ name Probl ems
  20717   "RTN","VPR ENSZ",12,0 )
  20718    D REPORT( 9000011,"P RB")
  20719   "RTN","VPR ENSZ",13,0 )
  20720    Q
  20721   "RTN","VPR ENSZ",14,0 )
  20722   DOC ;@type  DOCUMENT  @name Docu ments
  20723   "RTN","VPR ENSZ",15,0 )
  20724    D REPORT( 8925,"DOC" )
  20725   "RTN","VPR ENSZ",16,0 )
  20726    Q
  20727   "RTN","VPR ENSZ",17,0 )
  20728   ENC ;@type  VISIT @na me Encount ers
  20729   "RTN","VPR ENSZ",18,0 )
  20730    D REPORT( 9000010,"E NC")
  20731   "RTN","VPR ENSZ",19,0 )
  20732    Q
  20733   "RTN","VPR ENSZ",20,0 )
  20734   ACC ;@type  ACCESSION  @name Acc essions
  20735   "RTN","VPR ENSZ",21,0 )
  20736    D REPORT( "63ACC","A CC")
  20737   "RTN","VPR ENSZ",22,0 )
  20738    Q
  20739   "RTN","VPR ENSZ",23,0 )
  20740   LAB ;@type  LAB @name  Lab Resul ts
  20741   "RTN","VPR ENSZ",24,0 )
  20742    D REPORT( 63,"LAB")
  20743   "RTN","VPR ENSZ",25,0 )
  20744    Q
  20745   "RTN","VPR ENSZ",26,0 )
  20746   MIC ;@name  Micro/AP  Collection s
  20747   "RTN","VPR ENSZ",27,0 )
  20748    D REPORT( "63MI","MI C")
  20749   "RTN","VPR ENSZ",28,0 )
  20750    Q
  20751   "RTN","VPR ENSZ",29,0 )
  20752   RAD ;@type  RADIOLOGY  @name Rad iology Pro cedures
  20753   "RTN","VPR ENSZ",30,0 )
  20754    D REPORT( 70,"RAD")
  20755   "RTN","VPR ENSZ",31,0 )
  20756    Q
  20757   "RTN","VPR ENSZ",32,0 )
  20758   VIT ;@type  VITAL @na me Vital M easurement s
  20759   "RTN","VPR ENSZ",33,0 )
  20760    D REPORT( 120.5,"VIT ")
  20761   "RTN","VPR ENSZ",34,0 )
  20762    Q
  20763   "RTN","VPR ENSZ",35,0 )
  20764   RXI ;@type  MED @name  Inpatient  Medicatio ns
  20765   "RTN","VPR ENSZ",36,0 )
  20766    D REPORT( 55,"RXI")
  20767   "RTN","VPR ENSZ",37,0 )
  20768    Q
  20769   "RTN","VPR ENSZ",38,0 )
  20770   RXO ;@type  RX @name  Outpatient  Medicatio ns
  20771   "RTN","VPR ENSZ",39,0 )
  20772    D REPORT( 52,"RXO")
  20773   "RTN","VPR ENSZ",40,0 )
  20774    Q
  20775   "RTN","VPR ENSZ",41,0 )
  20776   NVA ;@type  MED @name  Non-VA Me dications
  20777   "RTN","VPR ENSZ",42,0 )
  20778    D REPORT( "55NVA","N VA")
  20779   "RTN","VPR ENSZ",43,0 )
  20780    Q
  20781   "RTN","VPR ENSZ",44,0 )
  20782   ORD ;@name  Orders
  20783   "RTN","VPR ENSZ",45,0 )
  20784    D REPORT( 100,"ORD")
  20785   "RTN","VPR ENSZ",46,0 )
  20786    Q
  20787   "RTN","VPR ENSZ",47,0 )
  20788   OBS ;@name  Observati ons
  20789   "RTN","VPR ENSZ",48,0 )
  20790    D REPORT( 704.117,"O BS")
  20791   "RTN","VPR ENSZ",49,0 )
  20792    Q
  20793   "RTN","VPR ENSZ",50,0 )
  20794   REPORT(FIL E,TAG) ; l oop thru r eminder in dex, calul ate stats  & show rep ort
  20795   "RTN","VPR ENSZ",51,0 )
  20796    D ILOOP(F ILE,TAG),C ALC(TAG),S AVE(TAG),S HOW(TAG)
  20797   "RTN","VPR ENSZ",52,0 )
  20798    K ^TMP($J )
  20799   "RTN","VPR ENSZ",53,0 )
  20800    Q
  20801   "RTN","VPR ENSZ",54,0 )
  20802   ILOOP(FN,T AG) ;
  20803   "RTN","VPR ENSZ",55,0 )
  20804    K ^TMP($J )
  20805   "RTN","VPR ENSZ",56,0 )
  20806    N PT,PTDF N,CNT,TOTP T,HIGHCNT, TOTREC
  20807   "RTN","VPR ENSZ",57,0 )
  20808    S TOTPT=0 ,TOTREC=0, HIGHCNT=0
  20809   "RTN","VPR ENSZ",58,0 )
  20810    S PT=0 F   S PT=$$NE XTPT(FN,PT ) Q:'PT  D
  20811   "RTN","VPR ENSZ",59,0 )
  20812    . S TOTPT =TOTPT+1 W :TOTPT#100 =0 "."
  20813   "RTN","VPR ENSZ",60,0 )
  20814    . I "^55^ 55NVA^52^1 00^"[("^"_ FN_"^") S  CNT=$$LP1( PT,FN)
  20815   "RTN","VPR ENSZ",61,0 )
  20816    . I "^63^ 70^120.5^" [("^"_FN_" ^") S CNT= $$LP2(PT,F N)
  20817   "RTN","VPR ENSZ",62,0 )
  20818    . I "63MI "=FN S CNT =$$LPMI(PT )
  20819   "RTN","VPR ENSZ",63,0 )
  20820    . I "63AC C"=FN S CN T=$$LPACC( PT)
  20821   "RTN","VPR ENSZ",64,0 )
  20822    . I 8925= FN S CNT=$ $LPDOC(PT)
  20823   "RTN","VPR ENSZ",65,0 )
  20824    . I 120.8 =FN S CNT= $$LPALG(PT )
  20825   "RTN","VPR ENSZ",66,0 )
  20826    . I 90000 11=FN S CN T=$$LPROB( PT)
  20827   "RTN","VPR ENSZ",67,0 )
  20828    . I 90000 10=FN S CN T=$$LPVST( PT)
  20829   "RTN","VPR ENSZ",68,0 )
  20830    . I FN=70 4.117 S CN T=$$MDC^VP RENSZ(PT)
  20831   "RTN","VPR ENSZ",69,0 )
  20832    . Q:'CNT
  20833   "RTN","VPR ENSZ",70,0 )
  20834    . I (FN=" 63ACC"),($ P(^LR(PT,0 ),"^",2)'= 2) Q  ;non -patient c ollection
  20835   "RTN","VPR ENSZ",71,0 )
  20836    . S PTDFN =$S(FN="63 ACC":$P(^L R(PT,0),"^ ",3),1:PT)
  20837   "RTN","VPR ENSZ",72,0 )
  20838    . I CNT>H IGHCNT S H IGHCNT=CNT
  20839   "RTN","VPR ENSZ",73,0 )
  20840    . S ^TMP( $J,TAG,"FR EQ",CNT)=+ $G(^TMP($J ,TAG,"FREQ ",CNT))+1
  20841   "RTN","VPR ENSZ",74,0 )
  20842    . S ^TMP( $J,TAG,"CO UNT",CNT,P TDFN)="",T OTREC=TOTR EC+CNT
  20843   "RTN","VPR ENSZ",75,0 )
  20844    S ^TMP($J ,TAG,"STAT S","Highes tCount")=H IGHCNT
  20845   "RTN","VPR ENSZ",76,0 )
  20846    S ^TMP($J ,TAG,"STAT S","TotalR ecords")=T OTREC
  20847   "RTN","VPR ENSZ",77,0 )
  20848    S ^TMP($J ,TAG,"STAT S","TotalP atients")= TOTPT
  20849   "RTN","VPR ENSZ",78,0 )
  20850    Q
  20851   "RTN","VPR ENSZ",79,0 )
  20852   NEXTPT(FN, PT) ; Retu rns the ne xt patient  based on  PT passed  in
  20853   "RTN","VPR ENSZ",80,0 )
  20854    I FN="63M I" Q $O(^P XRMINDX(63 ,"PDI",PT) )
  20855   "RTN","VPR ENSZ",81,0 )
  20856    I FN="63A CC" Q $O(^ LR(PT))
  20857   "RTN","VPR ENSZ",82,0 )
  20858    I FN=8925  Q $O(^TIU (8925,"C", PT))
  20859   "RTN","VPR ENSZ",83,0 )
  20860    I FN=120. 8 Q $O(^GM R(120.8,"B ",PT))
  20861   "RTN","VPR ENSZ",84,0 )
  20862    I FN=9000 011 Q $O(^ AUPNPROB(" AC",PT))
  20863   "RTN","VPR ENSZ",85,0 )
  20864    I FN=9000 010 Q $O(^ AUPNVSIT(" C",PT))
  20865   "RTN","VPR ENSZ",86,0 )
  20866    I FN=704. 117 Q $O(^ MDC(704.11 7,"PT",PT) )
  20867   "RTN","VPR ENSZ",87,0 )
  20868    Q $O(^PXR MINDX(FN," PI",PT))
  20869   "RTN","VPR ENSZ",88,0 )
  20870    ;
  20871   "RTN","VPR ENSZ",89,0 )
  20872   LP1(PT,FN)  ; return  count for  indexes wi th start/s top dates
  20873   "RTN","VPR ENSZ",90,0 )
  20874    N CNT S C NT=0
  20875   "RTN","VPR ENSZ",91,0 )
  20876    N ITM,STR T,STOP,DAS
  20877   "RTN","VPR ENSZ",92,0 )
  20878    S ITM=""  F  S ITM=$ O(^PXRMIND X(FN,"PI", PT,ITM)) Q :ITM=""  D
  20879   "RTN","VPR ENSZ",93,0 )
  20880    . S STRT= "" F  S ST RT=$O(^PXR MINDX(FN," PI",PT,ITM ,STRT)) Q: STRT=""  D
  20881   "RTN","VPR ENSZ",94,0 )
  20882    . . S STO P="" F  S  STOP=$O(^P XRMINDX(FN ,"PI",PT,I TM,STRT,ST OP)) Q:STO P=""  D
  20883   "RTN","VPR ENSZ",95,0 )
  20884    . . . S D AS="" F  S  DAS=$O(^P XRMINDX(FN ,"PI",PT,I TM,STRT,ST OP,DAS)) Q :DAS=""  S  CNT=CNT+1
  20885   "RTN","VPR ENSZ",96,0 )
  20886    Q CNT
  20887   "RTN","VPR ENSZ",97,0 )
  20888    ;
  20889   "RTN","VPR ENSZ",98,0 )
  20890   LP2(PT,FN)  ; return  count for  indexes wi th date on ly
  20891   "RTN","VPR ENSZ",99,0 )
  20892    N CNT S C NT=0
  20893   "RTN","VPR ENSZ",100, 0)
  20894    N ITM,DAT E,DAS
  20895   "RTN","VPR ENSZ",101, 0)
  20896    S ITM=""  F  S ITM=$ O(^PXRMIND X(FN,"PI", PT,ITM)) Q :ITM=""  D
  20897   "RTN","VPR ENSZ",102, 0)
  20898    . S DATE= "" F  S DA TE=$O(^PXR MINDX(FN," PI",PT,ITM ,DATE)) Q: DATE=""  D
  20899   "RTN","VPR ENSZ",103, 0)
  20900    . . S DAS ="" F  S D AS=$O(^PXR MINDX(FN," PI",PT,ITM ,DATE,DAS) ) Q:DAS=""   S CNT=CN T+1
  20901   "RTN","VPR ENSZ",104, 0)
  20902    Q CNT
  20903   "RTN","VPR ENSZ",105, 0)
  20904    ;
  20905   "RTN","VPR ENSZ",106, 0)
  20906   LPMI(PT) ;  return co unt for mi cro/anatom ic path co llections
  20907   "RTN","VPR ENSZ",107, 0)
  20908    N CNT S C NT=0
  20909   "RTN","VPR ENSZ",108, 0)
  20910    N DATE
  20911   "RTN","VPR ENSZ",109, 0)
  20912    S DATE=""  F  S DATE =$O(^PXRMI NDX(63,"PD I",PT,DATE )) Q:DATE= ""  S CNT= CNT+1
  20913   "RTN","VPR ENSZ",110, 0)
  20914    Q CNT
  20915   "RTN","VPR ENSZ",111, 0)
  20916    ;
  20917   "RTN","VPR ENSZ",112, 0)
  20918   LPDOC(PT)  ; return c ount for T IU documen ts
  20919   "RTN","VPR ENSZ",113, 0)
  20920    N CNT S C NT=0
  20921   "RTN","VPR ENSZ",114, 0)
  20922    N DA
  20923   "RTN","VPR ENSZ",115, 0)
  20924    S DA=0 F   S DA=$O(^ TIU(8925," C",PT,DA))  Q:'DA  S  CNT=CNT+1
  20925   "RTN","VPR ENSZ",116, 0)
  20926    Q CNT
  20927   "RTN","VPR ENSZ",117, 0)
  20928    ;
  20929   "RTN","VPR ENSZ",118, 0)
  20930    ;N CNT S  CNT=0
  20931   "RTN","VPR ENSZ",119, 0)
  20932    ;N CLS,TM ,DA
  20933   "RTN","VPR ENSZ",120, 0)
  20934    ;S CLS=0  F  S CLS=$ O(^TIU(892 5,"ACLPT", CLS)) Q:'C LS  D
  20935   "RTN","VPR ENSZ",121, 0)
  20936    ;. S TM=0  F  S TM=$ O(^TIU(892 5,"ACLPT", CLS,PT,TM) ) Q:'TM  D
  20937   "RTN","VPR ENSZ",122, 0)
  20938    ;. . S DA =0 F  S DA =$O(^TIU(8 925,"ACLPT ",CLS,PT,T M,DA)) Q:' DA  S CNT= CNT+1
  20939   "RTN","VPR ENSZ",123, 0)
  20940    ;Q CNT
  20941   "RTN","VPR ENSZ",124, 0)
  20942    ;
  20943   "RTN","VPR ENSZ",125, 0)
  20944    ;N CNT S  CNT=0
  20945   "RTN","VPR ENSZ",126, 0)
  20946    ;N DOC,TM
  20947   "RTN","VPR ENSZ",127, 0)
  20948    ;S DOC=0  F  S DOC=$ O(^TIU(892 5,"AA",PT, DOC)) Q:'D OC  D
  20949   "RTN","VPR ENSZ",128, 0)
  20950    ;. S TM=0  F  S TM=$ O(^TIU(892 5,"AA",PT, DOC,TM)) Q :'TM  D
  20951   "RTN","VPR ENSZ",129, 0)
  20952    ;. . S DA =0 F  S DA =$O(^TIU(8 925,"AA",P T,DOC,TM,D A)) Q:'DA   S CNT=CNT +1
  20953   "RTN","VPR ENSZ",130, 0)
  20954    ;Q CNT
  20955   "RTN","VPR ENSZ",131, 0)
  20956    ;
  20957   "RTN","VPR ENSZ",132, 0)
  20958   LPALG(PT)  ; return c ount for a llergies
  20959   "RTN","VPR ENSZ",133, 0)
  20960    N CNT S C NT=0
  20961   "RTN","VPR ENSZ",134, 0)
  20962    N DA S DA =0
  20963   "RTN","VPR ENSZ",135, 0)
  20964    F  S DA=$ O(^GMR(120 .8,"B",PT, DA)) Q:'DA   S CNT=CN T+1
  20965   "RTN","VPR ENSZ",136, 0)
  20966    Q CNT
  20967   "RTN","VPR ENSZ",137, 0)
  20968    ;
  20969   "RTN","VPR ENSZ",138, 0)
  20970   LPROB(PT)  ; return c ount for p roblems
  20971   "RTN","VPR ENSZ",139, 0)
  20972    N CNT S C NT=0
  20973   "RTN","VPR ENSZ",140, 0)
  20974    N DA S DA =0
  20975   "RTN","VPR ENSZ",141, 0)
  20976    F  S DA=$ O(^AUPNPRO B("AC",PT, DA)) Q:'DA   S CNT=CN T+1
  20977   "RTN","VPR ENSZ",142, 0)
  20978    Q CNT
  20979   "RTN","VPR ENSZ",143, 0)
  20980    ;
  20981   "RTN","VPR ENSZ",144, 0)
  20982   LPVST(PT)  ; return c ount for v isits
  20983   "RTN","VPR ENSZ",145, 0)
  20984    N CNT S C NT=0
  20985   "RTN","VPR ENSZ",146, 0)
  20986    N DA S DA =0
  20987   "RTN","VPR ENSZ",147, 0)
  20988    F  S DA=$ O(^AUPNVSI T("C",PT,D A)) Q:'DA   D
  20989   "RTN","VPR ENSZ",148, 0)
  20990    . I "AHSR "[$P(^AUPN VSIT(DA,0) ,"^",7) S  CNT=CNT+1
  20991   "RTN","VPR ENSZ",149, 0)
  20992    . ; (only  include a mbulatory,  hospitali zation, su rgery, and  nursing h ome)
  20993   "RTN","VPR ENSZ",150, 0)
  20994    Q CNT
  20995   "RTN","VPR ENSZ",151, 0)
  20996    ;
  20997   "RTN","VPR ENSZ",152, 0)
  20998   LPACC(PT)  ; return c ount of ac cessions
  20999   "RTN","VPR ENSZ",153, 0)
  21000    N CNT S C NT=0
  21001   "RTN","VPR ENSZ",154, 0)
  21002    N ACC S A CC=0
  21003   "RTN","VPR ENSZ",155, 0)
  21004    F  S ACC= $O(^LR(PT, "CH",ACC))  Q:'ACC  S  CNT=CNT+1
  21005   "RTN","VPR ENSZ",156, 0)
  21006    Q CNT
  21007   "RTN","VPR ENSZ",157, 0)
  21008    ; 
  21009   "RTN","VPR ENSZ",158, 0)
  21010   CALC(TAG)  ; calculat e statisti cs for a T AG
  21011   "RTN","VPR ENSZ",159, 0)
  21012    ; find th e highest  item coun
  21013   "RTN","VPR ENSZ",160, 0)
  21014    N MAX S M AX=^TMP($J ,TAG,"STAT S","Highes tCount")
  21015   "RTN","VPR ENSZ",161, 0)
  21016    D MAXPTS( TAG,MAX)
  21017   "RTN","VPR ENSZ",162, 0)
  21018    ;
  21019   "RTN","VPR ENSZ",163, 0)
  21020    ; find th e average  item count
  21021   "RTN","VPR ENSZ",164, 0)
  21022    N PTS,MEA N
  21023   "RTN","VPR ENSZ",165, 0)
  21024    S PTS=^TM P($J,TAG," STATS","To talPatient s"),MEAN=0
  21025   "RTN","VPR ENSZ",166, 0)
  21026    I PTS S M EAN=^TMP($ J,TAG,"STA TS","Total Records")\ PTS
  21027   "RTN","VPR ENSZ",167, 0)
  21028    D ADDPTS( TAG,"MEAN" ,MEAN)
  21029   "RTN","VPR ENSZ",168, 0)
  21030    ;
  21031   "RTN","VPR ENSZ",169, 0)
  21032    ; find th e median i tem count
  21033   "RTN","VPR ENSZ",170, 0)
  21034    N POS,CNT ,PT,I
  21035   "RTN","VPR ENSZ",171, 0)
  21036    S:PTS#2 P TS=PTS+1 S  POS=PTS\2
  21037   "RTN","VPR ENSZ",172, 0)
  21038    S I=0
  21039   "RTN","VPR ENSZ",173, 0)
  21040    S CNT=0 F   S CNT=$O (^TMP($J,T AG,"COUNT" ,CNT)) Q:' CNT  D  Q: I'<POS
  21041   "RTN","VPR ENSZ",174, 0)
  21042    . S PT=0  F  S PT=$O (^TMP($J,T AG,"COUNT" ,CNT,PT))  Q:'PT  S I =I+1 Q:I'< POS
  21043   "RTN","VPR ENSZ",175, 0)
  21044    D ADDPTS( TAG,"MEDIA N",CNT)
  21045   "RTN","VPR ENSZ",176, 0)
  21046    ;
  21047   "RTN","VPR ENSZ",177, 0)
  21048    N HIGH,MO DE S HIGH= 0,MODE=0,C NT=0
  21049   "RTN","VPR ENSZ",178, 0)
  21050    F  S CNT= +$O(^TMP($ J,TAG,"COU NT",CNT))  Q:'CNT  D
  21051   "RTN","VPR ENSZ",179, 0)
  21052    . I ^TMP( $J,TAG,"FR EQ",CNT)>H IGH S HIGH =^(CNT),MO DE=CNT
  21053   "RTN","VPR ENSZ",180, 0)
  21054    D ADDPTS( TAG,"MODE" ,MODE)
  21055   "RTN","VPR ENSZ",181, 0)
  21056    ;
  21057   "RTN","VPR ENSZ",182, 0)
  21058    D MINPTS( TAG)
  21059   "RTN","VPR ENSZ",183, 0)
  21060    ;
  21061   "RTN","VPR ENSZ",184, 0)
  21062    K ^TMP($J ,TAG,"COUN T") ; rele ase space
  21063   "RTN","VPR ENSZ",185, 0)
  21064    ;S CNT=0  F  S CNT=$ O(^TMP($J, TAG,"FREQ" ,CNT)) Q:' CNT  W !,C NT_"="_^(C NT)
  21065   "RTN","VPR ENSZ",186, 0)
  21066    ;
  21067   "RTN","VPR ENSZ",187, 0)
  21068    Q
  21069   "RTN","VPR ENSZ",188, 0)
  21070   ADDPTS(TAG ,STAT,CNT)  ; add pat ients that  represent  this meas urement
  21071   "RTN","VPR ENSZ",189, 0)
  21072    S ^TMP($J ,TAG,"STAT S",STAT)=C NT
  21073   "RTN","VPR ENSZ",190, 0)
  21074    Q:CNT=""
  21075   "RTN","VPR ENSZ",191, 0)
  21076    N PT,TOTP T,MAXPT
  21077   "RTN","VPR ENSZ",192, 0)
  21078    S TOTPT=0 ,MAXPT=5
  21079   "RTN","VPR ENSZ",193, 0)
  21080    S PT="" ;  since we  are revers e ordering ...
  21081   "RTN","VPR ENSZ",194, 0)
  21082    F  S PT=$ O(^TMP($J, TAG,"COUNT ",CNT,PT), -1) Q:'PT   D  Q:TOTP T'<MAXPT
  21083   "RTN","VPR ENSZ",195, 0)
  21084    . S TOTPT =TOTPT+1
  21085   "RTN","VPR ENSZ",196, 0)
  21086    . S ^TMP( $J,TAG,"ST ATS",STAT, TOTPT)=$P( ^DPT(PT,0) ,"^")_"^"_ PT
  21087   "RTN","VPR ENSZ",197, 0)
  21088    Q
  21089   "RTN","VPR ENSZ",198, 0)
  21090   MINPTS(TAG ) ; store  the top 10  patients  with the h ighest cou nts
  21091   "RTN","VPR ENSZ",199, 0)
  21092    N PT,TOTP T,MAXPT
  21093   "RTN","VPR ENSZ",200, 0)
  21094    S CNT=0,T OTPT=0,MAX PT=10
  21095   "RTN","VPR ENSZ",201, 0)
  21096    F  S CNT= $O(^TMP($J ,TAG,"COUN T",CNT)) Q :'CNT  D   Q:TOTPT'<M AXPT
  21097   "RTN","VPR ENSZ",202, 0)
  21098    .I $G(^TM P($J,TAG," STATS","MI N"))="" S  ^TMP($J,TA G,"STATS", "MIN")=CNT
  21099   "RTN","VPR ENSZ",203, 0)
  21100    . S PT=0  F  S PT=$O (^TMP($J,T AG,"COUNT" ,CNT,PT))  Q:'PT  D   Q:TOTPT'<M AXPT
  21101   "RTN","VPR ENSZ",204, 0)
  21102    . . S TOT PT=TOTPT+1
  21103   "RTN","VPR ENSZ",205, 0)
  21104    . . S ^TM P($J,TAG," STATS","MI N",TOTPT)= $P(^DPT(PT ,0),"^")_" ^"_PT_"^"_ CNT
  21105   "RTN","VPR ENSZ",206, 0)
  21106    I $G(^TMP ($J,TAG,"S TATS","MIN "))="" S ^ TMP($J,TAG ,"STATS"," MIN")=0
  21107   "RTN","VPR ENSZ",207, 0)
  21108    Q
  21109   "RTN","VPR ENSZ",208, 0)
  21110   MAXPTS(TAG ,CNT) ; st ore the to p 10 patie nts with t he highest  counts
  21111   "RTN","VPR ENSZ",209, 0)
  21112    S ^TMP($J ,TAG,"STAT S","MAX")= CNT
  21113   "RTN","VPR ENSZ",210, 0)
  21114    N PT,TOTP T,MAXPT
  21115   "RTN","VPR ENSZ",211, 0)
  21116    S CNT=CNT +1,TOTPT=0 ,MAXPT=10
  21117   "RTN","VPR ENSZ",212, 0)
  21118    F  S CNT= $O(^TMP($J ,TAG,"COUN T",CNT),-1 ) Q:'CNT   D  Q:TOTPT '<MAXPT
  21119   "RTN","VPR ENSZ",213, 0)
  21120    . S PT=0  F  S PT=$O (^TMP($J,T AG,"COUNT" ,CNT,PT))  Q:'PT  D   Q:TOTPT'<M AXPT
  21121   "RTN","VPR ENSZ",214, 0)
  21122    . . S TOT PT=TOTPT+1
  21123   "RTN","VPR ENSZ",215, 0)
  21124    . . S ^TM P($J,TAG," STATS","MA X",TOTPT)= $P(^DPT(PT ,0),"^")_" ^"_PT_"^"_ CNT
  21125   "RTN","VPR ENSZ",216, 0)
  21126    Q
  21127   "RTN","VPR ENSZ",217, 0)
  21128   SAVE(TAG)  ; save the  TAG measu rements in  ^XTMP
  21129   "RTN","VPR ENSZ",218, 0)
  21130    S ^XTMP(" VPRENSZ-DO MAINS",0)= $$FMADD^XL FDT(DT,30) _U_DT
  21131   "RTN","VPR ENSZ",219, 0)
  21132    K ^XTMP(" VPRENSZ-DO MAINS",TAG )
  21133   "RTN","VPR ENSZ",220, 0)
  21134    M ^XTMP(" VPRENSZ-DO MAINS",TAG ,"FREQ")=^ TMP($J,TAG ,"FREQ")
  21135   "RTN","VPR ENSZ",221, 0)
  21136    M ^XTMP(" VPRENSZ-DO MAINS",TAG ,"STATS")= ^TMP($J,TA G,"STATS")
  21137   "RTN","VPR ENSZ",222, 0)
  21138    Q
  21139   "RTN","VPR ENSZ",223, 0)
  21140   SHOW(TAG)  ; show inf ormation a bout sizes
  21141   "RTN","VPR ENSZ",224, 0)
  21142    N STATS M  STATS=^TM P($J,TAG," STATS")
  21143   "RTN","VPR ENSZ",225, 0)
  21144    N DOMAIN  S DOMAIN=$ $DOMNAME(T AG)
  21145   "RTN","VPR ENSZ",226, 0)
  21146    W !!,DOMA IN,", Pati ents Searc hed: ",STA TS("TotalP atients")
  21147   "RTN","VPR ENSZ",227, 0)
  21148    W "    To tal Record s: ",STATS ("TotalRec ords"),"   "
  21149   "RTN","VPR ENSZ",228, 0)
  21150    N I F I=$ X:1:76 W " -"
  21151   "RTN","VPR ENSZ",229, 0)
  21152    W !!,DOMA IN," Maxim um (top te n):  ",STA TS("MAX")  D LSTPT(TA G,"MAX")
  21153   "RTN","VPR ENSZ",230, 0)
  21154    W !!,DOMA IN," Mean  (average):   ",STATS( "MEAN") D  LSTPT(TAG, "MEAN")
  21155   "RTN","VPR ENSZ",231, 0)
  21156    W !!,DOMA IN," Media n (middle) :  ",STATS ("MEDIAN")  D LSTPT(T AG,"MEDIAN ")
  21157   "RTN","VPR ENSZ",232, 0)
  21158    W !!,DOMA IN," Mode  (most comm on):  ",ST ATS("MODE" ) D LSTPT( TAG,"MODE" )
  21159   "RTN","VPR ENSZ",233, 0)
  21160    W !!,DOMA IN," Small est (top t en):  ",ST ATS("MIN")  D LSTPT(T AG,"MIN")
  21161   "RTN","VPR ENSZ",234, 0)
  21162    Q
  21163   "RTN","VPR ENSZ",235, 0)
  21164   LSTPT(TAG, STAT) ; li st sample  patients m atching cr iteria
  21165   "RTN","VPR ENSZ",236, 0)
  21166    N I,X,CNT  S CNT=0
  21167   "RTN","VPR ENSZ",237, 0)
  21168    S I=0 F   S I=$O(^TM P($J,TAG," STATS",STA T,I)) Q:'I   D
  21169   "RTN","VPR ENSZ",238, 0)
  21170    . S X=^TM P($J,TAG," STATS",STA T,I),CNT=C NT+1
  21171   "RTN","VPR ENSZ",239, 0)
  21172    . W !,?2, $P(X,"^"), ?44,$P(X," ^",2)
  21173   "RTN","VPR ENSZ",240, 0)
  21174    . I $P(X, "^",3) W ? 62,$P(X,"^ ",3)," rec ords"
  21175   "RTN","VPR ENSZ",241, 0)
  21176    Q
  21177   "RTN","VPR ENSZ",242, 0)
  21178   DOMNAME(TA G) ; retur n full TAG  name give n tag
  21179   "RTN","VPR ENSZ",243, 0)
  21180    N X,NAME
  21181   "RTN","VPR ENSZ",244, 0)
  21182    S X=$T(@( TAG_"^VPRE NSZ")),NAM E=$E(X,$F( X,"@name " ),$L(X))
  21183   "RTN","VPR ENSZ",245, 0)
  21184    Q NAME
  21185   "RTN","VPR ENSZ",246, 0)
  21186    ;
  21187   "RTN","VPR ENSZ",247, 0)
  21188   VTYPES ; d ump visit  types
  21189   "RTN","VPR ENSZ",248, 0)
  21190    S DFN=0 F   S DFN=$O (^AUPNVSIT ("C",DFN))  Q:'DFN  D
  21191   "RTN","VPR ENSZ",249, 0)
  21192    . S DA=0  F  S DA=$O (^AUPNVSIT ("C",DFN,D A)) Q:'DA   D
  21193   "RTN","VPR ENSZ",250, 0)
  21194    .. W !,DF N,?10,$P(^ AUPNVSIT(D A,0),"^",7 )
  21195   "RTN","VPR ENSZ",251, 0)
  21196    Q
  21197   "RTN","VPR ENSZ",252, 0)
  21198   TCOMP ; te st compila tion
  21199   "RTN","VPR ENSZ",253, 0)
  21200    W !,"This  compiles  on VDEV"
  21201   "RTN","VPR ENSZ",254, 0)
  21202    Q
  21203   "RTN","VPR ENSZ",255, 0)
  21204   MDC(PT) ;  Observatio ns in clio  for a pt.
  21205   "RTN","VPR ENSZ",256, 0)
  21206    ; Run the  PT XREF o n the OBS  file (704. 117)
  21207   "RTN","VPR ENSZ",257, 0)
  21208    N CNT,OBS DT,OBSIFN  S OBSDT="" ,OBSIFN="" ,CNT=0
  21209   "RTN","VPR ENSZ",258, 0)
  21210    F  S OBSD T=$O(^MDC( 704.117,"P T",PT,OBSD T)) Q:OBSD T=""  D
  21211   "RTN","VPR ENSZ",259, 0)
  21212    .F  S OBS IFN=$O(^MD C(704.117, "PT",PT,OB SDT,OBSIFN )) Q:OBSIF N=""  D
  21213   "RTN","VPR ENSZ",260, 0)
  21214    ..S CNT=C NT+1
  21215   "RTN","VPR ENSZ",261, 0)
  21216    Q CNT
  21217   "RTN","VPR ENSZ1")
  21218   0^57^B1068 6788
  21219   "RTN","VPR ENSZ1",1,0 )
  21220   VPRENSZ1 ; SLC/KCM -  Measure da ta sizes
  21221   "RTN","VPR ENSZ1",2,0 )
  21222    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  21223   "RTN","VPR ENSZ1",3,0 )
  21224    ;
  21225   "RTN","VPR ENSZ1",4,0 )
  21226   DOMAINS(LS T) ; RPC -  list of d omains for  which siz ing inform ation is a vailable
  21227   "RTN","VPR ENSZ1",5,0 )
  21228    N I,X,TAG ,NAME
  21229   "RTN","VPR ENSZ1",6,0 )
  21230    S LST=1,L ST(LST)="< domains>"
  21231   "RTN","VPR ENSZ1",7,0 )
  21232    F I=2:1 S  X=$T(@("+ "_I_"^VPRE NSZ")) Q:' $L(X)  I ( X?1.7U1" ; ".E),(X["@ name ") D
  21233   "RTN","VPR ENSZ1",8,0 )
  21234    . S TAG=$ P(X," ") S  NAME=$E(X ,$F(X,"@na me "),$L(X ))
  21235   "RTN","VPR ENSZ1",9,0 )
  21236    . S LST=L ST+1,LST(L ST)="<doma in tag='"_ TAG_"'>"_N AME_"</dom ain>"
  21237   "RTN","VPR ENSZ1",10, 0)
  21238    S LST=LST +1,LST(LST )="</domai ns>"
  21239   "RTN","VPR ENSZ1",11, 0)
  21240    Q
  21241   "RTN","VPR ENSZ1",12, 0)
  21242   STATS(LST, TAG) ; RPC  - list st ats, patie nts, & raw  data for  a domain
  21243   "RTN","VPR ENSZ1",13, 0)
  21244    N X,STATS ,FREQ,DOMA IN
  21245   "RTN","VPR ENSZ1",14, 0)
  21246    S X=$T(@( TAG_"^VPRE NSZ"))
  21247   "RTN","VPR ENSZ1",15, 0)
  21248    S DOMAIN= $E(X,$F(X, "@name "), $L(X))
  21249   "RTN","VPR ENSZ1",16, 0)
  21250    S TYPE=$P (X,"@type  ",2),TYPE= $P(TYPE,"  ")
  21251   "RTN","VPR ENSZ1",17, 0)
  21252    S LST=0
  21253   "RTN","VPR ENSZ1",18, 0)
  21254    I '$D(^XT MP("VPRENS Z-DOMAINS" ,TAG)) D E RRMSG(DOMA IN_"("_TAG _") size m easurement s unavaila ble.") Q
  21255   "RTN","VPR ENSZ1",19, 0)
  21256    ;
  21257   "RTN","VPR ENSZ1",20, 0)
  21258    M STATS=^ XTMP("VPRE NSZ-DOMAIN S",TAG,"ST ATS")
  21259   "RTN","VPR ENSZ1",21, 0)
  21260    ; M FREQ= ^XTMP("VPR ENSZ-DOMAI NS",TAG,"F REQ") - DO N'T NEED T HIS... 
  21261   "RTN","VPR ENSZ1",22, 0)
  21262    ;
  21263   "RTN","VPR ENSZ1",23, 0)
  21264    S X="<sta ts domain= '"_DOMAIN_ "' tag='"_ TAG_"' typ e='"_TYPE_ "' "
  21265   "RTN","VPR ENSZ1",24, 0)
  21266    S X=X_"pa tients='"_ STATS("Tot alPatients ")_"' "
  21267   "RTN","VPR ENSZ1",25, 0)
  21268    S X=X_"re cords='"_S TATS("Tota lRecords") _"' >"
  21269   "RTN","VPR ENSZ1",26, 0)
  21270    S LST=LST +1,LST(LST )=X
  21271   "RTN","VPR ENSZ1",27, 0)
  21272    ;
  21273   "RTN","VPR ENSZ1",28, 0)
  21274    S LST=LST +1,LST(LST )="<mean v alue='"_ST ATS("MEAN" )_"' >"
  21275   "RTN","VPR ENSZ1",29, 0)
  21276    D PTS2XML ("MEAN")
  21277   "RTN","VPR ENSZ1",30, 0)
  21278    S LST=LST +1,LST(LST )="</mean> "
  21279   "RTN","VPR ENSZ1",31, 0)
  21280    ;
  21281   "RTN","VPR ENSZ1",32, 0)
  21282    S LST=LST +1,LST(LST )="<median  value='"_ STATS("MED IAN")_"' > "
  21283   "RTN","VPR ENSZ1",33, 0)
  21284    D PTS2XML ("MEDIAN")
  21285   "RTN","VPR ENSZ1",34, 0)
  21286    S LST=LST +1,LST(LST )="</media n>"
  21287   "RTN","VPR ENSZ1",35, 0)
  21288    ;
  21289   "RTN","VPR ENSZ1",36, 0)
  21290    S LST=LST +1,LST(LST )="<mode v alue='"_ST ATS("MODE" )_"' >"
  21291   "RTN","VPR ENSZ1",37, 0)
  21292    D PTS2XML ("MODE")
  21293   "RTN","VPR ENSZ1",38, 0)
  21294    S LST=LST +1,LST(LST )="</mode> "
  21295   "RTN","VPR ENSZ1",39, 0)
  21296    ;
  21297   "RTN","VPR ENSZ1",40, 0)
  21298    S LST=LST +1,LST(LST )="<max va lue='"_STA TS("MAX")_ "' >"
  21299   "RTN","VPR ENSZ1",41, 0)
  21300    D PTS2XML ("MAX")
  21301   "RTN","VPR ENSZ1",42, 0)
  21302    S LST=LST +1,LST(LST )="</max>"
  21303   "RTN","VPR ENSZ1",43, 0)
  21304    ;
  21305   "RTN","VPR ENSZ1",44, 0)
  21306    D FREQ
  21307   "RTN","VPR ENSZ1",45, 0)
  21308    S LST=LST +1,LST(LST )="</stats >"
  21309   "RTN","VPR ENSZ1",46, 0)
  21310    Q
  21311   "RTN","VPR ENSZ1",47, 0)
  21312   PTS2XML(ST AT) ; add  patients t o the retu rn XML
  21313   "RTN","VPR ENSZ1",48, 0)
  21314    ; expects : LST, STA TS
  21315   "RTN","VPR ENSZ1",49, 0)
  21316    ; <patien t dfn=4323 423 count= 342234 icn =342432424 3>doe,john </patient>
  21317   "RTN","VPR ENSZ1",50, 0)
  21318    N I,X,NM, DFN,CNT,IC N
  21319   "RTN","VPR ENSZ1",51, 0)
  21320    S I=0 F   S I=$O(STA TS(STAT,I) ) Q:'I  D
  21321   "RTN","VPR ENSZ1",52, 0)
  21322    . S X=STA TS(STAT,I)
  21323   "RTN","VPR ENSZ1",53, 0)
  21324    . S NM=$P (X,U),DFN= $P(X,U,2), CNT=$P(X,U ,3)
  21325   "RTN","VPR ENSZ1",54, 0)
  21326    . S ICN=$ $GETICN^MP IF001(DFN)  S:+ICN<0  ICN=""
  21327   "RTN","VPR ENSZ1",55, 0)
  21328    . S LST=L ST+1
  21329   "RTN","VPR ENSZ1",56, 0)
  21330    . S LST(L ST)="<pati ent dfn='" _DFN_"' co unt='"_CNT _"' icn='" _ICN_"' >" _NM_"</pat ient>"
  21331   "RTN","VPR ENSZ1",57, 0)
  21332    Q
  21333   "RTN","VPR ENSZ1",58, 0)
  21334   FREQ ; add  RecordCou nt=Patient Count stri ngs
  21335   "RTN","VPR ENSZ1",59, 0)
  21336    N X,I
  21337   "RTN","VPR ENSZ1",60, 0)
  21338    S LST=LST +1,LST(LST )="<record Count>"
  21339   "RTN","VPR ENSZ1",61, 0)
  21340    S X="",I= 0 F  S I=$ O(^XTMP("V PRENSZ-DOM AINS",TAG, "FREQ",I))  Q:'I  D
  21341   "RTN","VPR ENSZ1",62, 0)
  21342    . S X=X_I _"," I $L( X)>72 S LS T=LST+1,LS T(LST)=X,X =""
  21343   "RTN","VPR ENSZ1",63, 0)
  21344    I $L(X) S  LST=LST+1 ,LST(LST)= X
  21345   "RTN","VPR ENSZ1",64, 0)
  21346    D NOCOMMA
  21347   "RTN","VPR ENSZ1",65, 0)
  21348    S LST=LST +1,LST(LST )="</recor dCount>"
  21349   "RTN","VPR ENSZ1",66, 0)
  21350    ; 
  21351   "RTN","VPR ENSZ1",67, 0)
  21352    S LST=LST +1,LST(LST )="<patien tCount>"
  21353   "RTN","VPR ENSZ1",68, 0)
  21354    S X="",I= 0 F  S I=$ O(^XTMP("V PRENSZ-DOM AINS",TAG, "FREQ",I))  Q:'I  D
  21355   "RTN","VPR ENSZ1",69, 0)
  21356    . S X=X_^ XTMP("VPRE NSZ-DOMAIN S",TAG,"FR EQ",I)_","
  21357   "RTN","VPR ENSZ1",70, 0)
  21358    . I $L(X) >72 S LST= LST+1,LST( LST)=X,X=" "
  21359   "RTN","VPR ENSZ1",71, 0)
  21360    I $L(X) S  LST=LST+1 ,LST(LST)= X
  21361   "RTN","VPR ENSZ1",72, 0)
  21362    D NOCOMMA
  21363   "RTN","VPR ENSZ1",73, 0)
  21364    S LST=LST +1,LST(LST )="</patie ntCount>"
  21365   "RTN","VPR ENSZ1",74, 0)
  21366    Q
  21367   "RTN","VPR ENSZ1",75, 0)
  21368   NOCOMMA ;
  21369   "RTN","VPR ENSZ1",76, 0)
  21370    I $E(LST( LST),$L(LS T(LST)))=" ," S LST(L ST)=$E(LST (LST),1,$L (LST(LST)) -1)
  21371   "RTN","VPR ENSZ1",77, 0)
  21372    Q
  21373   "RTN","VPR ENSZ1",78, 0)
  21374   ERRMSG(X)  ; build er ror messag e
  21375   "RTN","VPR ENSZ1",79, 0)
  21376    S LST=LST +1,LST(LST )="<error  msg='"_X_" ' />"
  21377   "RTN","VPR ENSZ1",80, 0)
  21378    Q
  21379   "RTN","VPR ENSZ1",81, 0)
  21380   CF ; Count  frequenci es
  21381   "RTN","VPR ENSZ1",82, 0)
  21382    S DOM=""  F  S DOM=$ O(^XTMP("V PRENSZ-DOM AINS",DOM) ) Q:DOM=""   D
  21383   "RTN","VPR ENSZ1",83, 0)
  21384    . S (I,T) =0 F  S I= $O(^XTMP(" VPRENSZ-DO MAINS",DOM ,"FREQ",I) ) Q:'I  S  T=T+1
  21385   "RTN","VPR ENSZ1",84, 0)
  21386    . W !,DOM ,"=",T
  21387   "RTN","VPR ENSZ1",85, 0)
  21388    Q
  21389   "RTN","VPR EVNT")
  21390   0^2^B10422 3314
  21391   "RTN","VPR EVNT",1,0)
  21392   VPREVNT ;S LC/MKB --  VistA even t listener s
  21393   "RTN","VPR EVNT",2,0)
  21394    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  21395   "RTN","VPR EVNT",3,0)
  21396    ;
  21397   "RTN","VPR EVNT",4,0)
  21398    ; Externa l Referenc es           DBIA#
  21399   "RTN","VPR EVNT",5,0)
  21400    ; ------- ---------- --           -----
  21401   "RTN","VPR EVNT",6,0)
  21402    ; DG FIEL D MONITOR               +3344
  21403   "RTN","VPR EVNT",7,0)
  21404    ; DGPM MO VEMENT EVE NTS          +1181
  21405   "RTN","VPR EVNT",8,0)
  21406    ; FH EVSE ND OR                   +
  21407   "RTN","VPR EVNT",9,0)
  21408    ; GMRA EN TERED IN E RROR         +1467
  21409   "RTN","VPR EVNT",10,0 )
  21410    ; GMRA SI GN-OFF ON  DATA         +1469
  21411   "RTN","VPR EVNT",11,0 )
  21412    ; GMRC EV SEND OR                 +3140
  21413   "RTN","VPR EVNT",12,0 )
  21414    ; LR70 CH  EVSEND OR              +3565 *
  21415   "RTN","VPR EVNT",13,0 )
  21416    ; MDC OBS ERVATION U PDATE        +
  21417   "RTN","VPR EVNT",14,0 )
  21418    ; OR EVSE ND *                    +3135
  21419   "RTN","VPR EVNT",15,0 )
  21420    ; PS EVSE ND OR                   +2415
  21421   "RTN","VPR EVNT",16,0 )
  21422    ; PXK VIS IT DATA EV ENT          +1298
  21423   "RTN","VPR EVNT",17,0 )
  21424    ; RA EVSE ND OR                   +
  21425   "RTN","VPR EVNT",18,0 )
  21426    ; SDAM AP POINTMENT  EVENTS       +1320
  21427   "RTN","VPR EVNT",19,0 )
  21428    ; ^AUPNVS IT                       2028
  21429   "RTN","VPR EVNT",20,0 )
  21430    ; ^DPT                            10035
  21431   "RTN","VPR EVNT",21,0 )
  21432    ; ^OR(100                          5771
  21433   "RTN","VPR EVNT",22,0 )
  21434    ; DIQ                              2056
  21435   "RTN","VPR EVNT",23,0 )
  21436    ; GMVUTL                           5046
  21437   "RTN","VPR EVNT",24,0 )
  21438    ; TIUSRVL O                        2834
  21439   "RTN","VPR EVNT",25,0 )
  21440    ; VADPT                           10061
  21441   "RTN","VPR EVNT",26,0 )
  21442    ; VASITE                          10112
  21443   "RTN","VPR EVNT",27,0 )
  21444    ; XLFDT                           10103
  21445   "RTN","VPR EVNT",28,0 )
  21446    ; XTHC10                           5515
  21447   "RTN","VPR EVNT",29,0 )
  21448    ;
  21449   "RTN","VPR EVNT",30,0 )
  21450   DG ; -- DG  FIELD MON ITOR proto col listen er
  21451   "RTN","VPR EVNT",31,0 )
  21452    Q:$G(DGFI LE)'=2          ;Pati ent file o nly
  21453   "RTN","VPR EVNT",32,0 )
  21454    N DFN S D FN=+$G(DGD A)
  21455   "RTN","VPR EVNT",33,0 )
  21456    ; operati onal pt-se lect
  21457   "RTN","VPR EVNT",34,0 )
  21458    I "^.01^. 02^.03^.09 ^.101^.351 ^.361^"[(U _+$G(DGFIE LD)_U) D P OSTX("pt-s elect",DFN _"&"_$G(DG FIELD))
  21459   "RTN","VPR EVNT",35,0 )
  21460    ; subscri bed patien t
  21461   "RTN","VPR EVNT",36,0 )
  21462    I $D(^VPR (560,"AITE M",DFN)),$ $FLD(+$G(D GFIELD)) D  POST(DFN, "patient", DFN)
  21463   "RTN","VPR EVNT",37,0 )
  21464    Q
  21465   "RTN","VPR EVNT",38,0 )
  21466    ;
  21467   "RTN","VPR EVNT",39,0 )
  21468   FLD(X) ; - -Return 1  or 0, if X  is a fiel d tracked  by VPR
  21469   "RTN","VPR EVNT",40,0 )
  21470    S X=U_+$G (X)_U
  21471   "RTN","VPR EVNT",41,0 )
  21472    I "^.01^. 02^.03^.05 ^.08^.09^. 351^.361^. 364^"[X Q  1          ;demograph ic
  21473   "RTN","VPR EVNT",42,0 )
  21474    I "^.111^ .1112^.112 ^.113^.114 ^.115^.131 ^.132^.134 ^"[X Q 1   ;addr/phon e
  21475   "RTN","VPR EVNT",43,0 )
  21476    I "^.211^ .212^.213^ .214^.216^ .217^.218^ .219^"[X Q  1         ;NOK
  21477   "RTN","VPR EVNT",44,0 )
  21478    I "^.301^ .302^1901^ .32102^.32 103^.32201 ^.5295^"[X  Q 1       ;serv conn
  21479   "RTN","VPR EVNT",45,0 )
  21480    Q 0
  21481   "RTN","VPR EVNT",46,0 )
  21482    ;
  21483   "RTN","VPR EVNT",47,0 )
  21484   DGPM ; --  DGPM MOVEM ENT EVENTS  protocol  listener
  21485   "RTN","VPR EVNT",48,0 )
  21486    ;    [exp ects DFN,D GPM* varia bles]
  21487   "RTN","VPR EVNT",49,0 )
  21488    N ADM,ACT  S ADM=DGP MDA
  21489   "RTN","VPR EVNT",50,0 )
  21490    I DGPMT'= 1 S ADM=$S (DGPMA:$P( DGPMA,U,14 ),1:$P(DGP MP,U,14))  Q:ADM<1
  21491   "RTN","VPR EVNT",51,0 )
  21492    S ACT=$S( DGPMA:"",1 :"@")
  21493   "RTN","VPR EVNT",52,0 )
  21494    I $D(^VPR (560,"AITE M",DFN)) D  POST(DFN, "visit","H "_ADM,ACT)
  21495   "RTN","VPR EVNT",53,0 )
  21496    ; update  roster(s)  if current  movement
  21497   "RTN","VPR EVNT",54,0 )
  21498    N ADMX,MV TX,PREV,NE W,OLD,WARD
  21499   "RTN","VPR EVNT",55,0 )
  21500    S ADMX=$Q (^DGPM("AT ID1",DFN))  Q:$QS(ADM X,4)'=ADM
  21501   "RTN","VPR EVNT",56,0 )
  21502    S MVTX=$Q (^DGPM("AP MV",DFN,AD M)) Q:$QS( MVTX,5)'=D GPMDA
  21503   "RTN","VPR EVNT",57,0 )
  21504    S PREV=$G (DGPMP) I  'PREV,DGPM T'=1 D  ;p revious or  edited mv t
  21505   "RTN","VPR EVNT",58,0 )
  21506    . S MVTX= $Q(@MVTX)  Q:DFN'=$QS (MVTX,2)   Q:ADM'=$QS (MVTX,3)
  21507   "RTN","VPR EVNT",59,0 )
  21508    . S PREV= $G(^DGPM(+ $QS(MVTX,5 ),0))
  21509   "RTN","VPR EVNT",60,0 )
  21510    S NEW=$P( DGPMA,U,6) ,OLD=$P(PR EV,U,6)
  21511   "RTN","VPR EVNT",61,0 )
  21512    I NEW'=OL D F WARD=N EW,OLD I W ARD D
  21513   "RTN","VPR EVNT",62,0 )
  21514    . S I=0 F   S I=$O(^ VPROSTER(" AD",WARD_" ;DIC(42,", I)) Q:I<1   D POSTX(" roster",I)
  21515   "RTN","VPR EVNT",63,0 )
  21516    Q
  21517   "RTN","VPR EVNT",64,0 )
  21518    ;-find vi sit# for c orrespondi ng admissi on [not us ed]
  21519   "RTN","VPR EVNT",65,0 )
  21520    N ADM,PTF ,IDT,ID,AC T
  21521   "RTN","VPR EVNT",66,0 )
  21522    I DGPMA S  ADM=+DGPM A,PTF=+$P( DGPMA,U,16 )
  21523   "RTN","VPR EVNT",67,0 )
  21524    E  S ADM= +DGPMP,PTF =+$P(DGPMP ,U,16)
  21525   "RTN","VPR EVNT",68,0 )
  21526    I DGPMT'= 1 D  Q:ADM <1
  21527   "RTN","VPR EVNT",69,0 )
  21528    . N VAIP  S VAIP("E" )=DGPMDA
  21529   "RTN","VPR EVNT",70,0 )
  21530    . D IN5^V ADPT S ADM =+VAIP(13, 1),PTF=+VA IP(12)
  21531   "RTN","VPR EVNT",71,0 )
  21532    S IDT=999 9999-$P(AD M,".") S:A DM["." IDT =IDT_"."_$ P(ADM,".", 2)
  21533   "RTN","VPR EVNT",72,0 )
  21534    S ID=+$O( ^AUPNVSIT( "AAH",DFN, IDT,0)) Q: 'ID
  21535   "RTN","VPR EVNT",73,0 )
  21536    S ACT=$S( DGPMA:"",1 :"@")
  21537   "RTN","VPR EVNT",74,0 )
  21538    D POST(DF N,"visit", ID,ACT)
  21539   "RTN","VPR EVNT",75,0 )
  21540    ; POST(DF N,"ptf",PT F,ACT):DGP MT=3
  21541   "RTN","VPR EVNT",76,0 )
  21542    Q
  21543   "RTN","VPR EVNT",77,0 )
  21544    ;
  21545   "RTN","VPR EVNT",78,0 )
  21546   NEWINPT()  ; -- is DF N newly ad mitted?
  21547   "RTN","VPR EVNT",79,0 )
  21548    N Y S Y=0
  21549   "RTN","VPR EVNT",80,0 )
  21550    I DGPMT=1 ,DGPMA,'DG PMP,+$G(^D PT(DFN,.10 5))=DGPMDA  S Y=1 ;ne w admissio n
  21551   "RTN","VPR EVNT",81,0 )
  21552    Q Y
  21553   "RTN","VPR EVNT",82,0 )
  21554    ;
  21555   "RTN","VPR EVNT",83,0 )
  21556   SDAM ; --  SDAM APPOI NTMENT EVE NTS protoc ol listene r
  21557   "RTN","VPR EVNT",84,0 )
  21558    I $G(SDAT A) D  Q  ; appointmen ts
  21559   "RTN","VPR EVNT",85,0 )
  21560    . N DFN,D ATE,HLOC,S TS,REASON, PROV
  21561   "RTN","VPR EVNT",86,0 )
  21562    . S DFN=+ $P(SDATA,U ,2) Q:DFN< 1
  21563   "RTN","VPR EVNT",87,0 )
  21564    . Q:'$D(^ VPR(560,"A ITEM",DFN) )
  21565   "RTN","VPR EVNT",88,0 )
  21566    . S DATE= +$P(SDATA, U,3),HLOC= +$P(SDATA, U,4),(PROV ,REASON)=" "
  21567   "RTN","VPR EVNT",89,0 )
  21568    . ;I SDAM EVT=1 K DI R S DIR(0) ="F^3:20", DIR("A")=" Enter Reas on for App ointment:  ",DIR("?") ="Answer m ust be 2-2 0 characte rs" D ^DIR  S REASON= Y
  21569   "RTN","VPR EVNT",90,0 )
  21570    . ;I SDAM EVT=1 K DI C S DIC="^ VA(200,",D IC("A")="S elect Pati ent's Prov ider: ",DI C(0)="AEQ" ,D="AK.PRO VIDER" D I X^DIC S PR OV=$P(Y,"^ ",1,2)
  21571   "RTN","VPR EVNT",91,0 )
  21572    . D POST( DFN,"appoi ntment","A ;"_DATE_"; "_HLOC_";" _REASON_"; "_$TR($P(P ROV,U,1,2) ,"^",";"))
  21573   "RTN","VPR EVNT",92,0 )
  21574    Q
  21575   "RTN","VPR EVNT",93,0 )
  21576    ;
  21577   "RTN","VPR EVNT",94,0 )
  21578   PCE ; -- P XK VISIT D ATA EVENT  protocol l istener
  21579   "RTN","VPR EVNT",95,0 )
  21580    N IEN,PX0 A,PX0B,DFN ,DA,ACT
  21581   "RTN","VPR EVNT",96,0 )
  21582    S IEN=+$O (^TMP("PXK CO",$J,0))  Q:IEN<1
  21583   "RTN","VPR EVNT",97,0 )
  21584    S PX0A=$G (^TMP("PXK CO",$J,IEN ,"VST",IEN ,0,"AFTER" )),PX0B=$G (^("BEFORE "))
  21585   "RTN","VPR EVNT",98,0 )
  21586    S DFN=$S( $L(PX0A):+ $P(PX0A,U, 5),1:+$P(P X0B,U,5))
  21587   "RTN","VPR EVNT",99,0 )
  21588    Q:DFN<1   Q:'$D(^VPR (560,"AITE M",DFN))
  21589   "RTN","VPR EVNT",100, 0)
  21590    ; Visit f ile
  21591   "RTN","VPR EVNT",101, 0)
  21592    S ACT=$S( PX0A="":"@ ",1:"")
  21593   "RTN","VPR EVNT",102, 0)
  21594    D POST(DF N,"visit", IEN,ACT)
  21595   "RTN","VPR EVNT",103, 0)
  21596    ; check V -files
  21597   "RTN","VPR EVNT",104, 0)
  21598    F SUB="HF ","IMM","X AM","CPT", "PED","POV ","SK" D
  21599   "RTN","VPR EVNT",105, 0)
  21600    . S DA=0  F  S DA=$O (^TMP("PXK CO",$J,IEN ,SUB,DA))  Q:DA<1  D
  21601   "RTN","VPR EVNT",106, 0)
  21602    .. S ACT= $S($G(^TMP ("PXKCO",$ J,IEN,SUB, DA,0,"AFTE R"))="":"@ ",1:"")
  21603   "RTN","VPR EVNT",107, 0)
  21604    .. D POST (DFN,$$NAM E(SUB),DA, ACT)
  21605   "RTN","VPR EVNT",108, 0)
  21606    Q
  21607   "RTN","VPR EVNT",109, 0)
  21608    ;
  21609   "RTN","VPR EVNT",110, 0)
  21610   NAME(X) ;  -- return  object nam e for V-fi les
  21611   "RTN","VPR EVNT",111, 0)
  21612    N Y S Y=" "
  21613   "RTN","VPR EVNT",112, 0)
  21614    I X="HF"   S Y="fact or"
  21615   "RTN","VPR EVNT",113, 0)
  21616    I X="IMM"  S Y="immu nization"
  21617   "RTN","VPR EVNT",114, 0)
  21618    I X="XAM"  S Y="exam "
  21619   "RTN","VPR EVNT",115, 0)
  21620    I X="CPT"  S Y="cpt"
  21621   "RTN","VPR EVNT",116, 0)
  21622    I X="PED"  S Y="educ ation"
  21623   "RTN","VPR EVNT",117, 0)
  21624    I X="POV"  S Y="pov"
  21625   "RTN","VPR EVNT",118, 0)
  21626    I X="SK"   S Y="skin "
  21627   "RTN","VPR EVNT",119, 0)
  21628    Q Y
  21629   "RTN","VPR EVNT",120, 0)
  21630    ;
  21631   "RTN","VPR EVNT",121, 0)
  21632   ZPCE ; --  old PXK VI SIT DATA E VENT proto col listen er [not in  use]
  21633   "RTN","VPR EVNT",122, 0)
  21634    N IEN,PX0 ,PX150,DFN ,DA
  21635   "RTN","VPR EVNT",123, 0)
  21636    S IEN=+$O (^TMP("PXK CO",$J,0))  Q:IEN<1
  21637   "RTN","VPR EVNT",124, 0)
  21638    S PX0=$G( ^TMP("PXKC O",$J,IEN, "VST",IEN, 0,"AFTER") ) Q:$P(PX0 ,U,7)="E"
  21639   "RTN","VPR EVNT",125, 0)
  21640    I PX0=""  D POST(DFN ,"visit",I EN,"@") Q   ;deleted
  21641   "RTN","VPR EVNT",126, 0)
  21642    S PX150=$ G(^TMP("PX KCO",$J,IE N,"VST",IE N,150,"AFT ER")) Q:$P (PX150,U,3 )'="P"
  21643   "RTN","VPR EVNT",127, 0)
  21644    S DFN=+$P (PX0,U,5)  Q:DFN<1  Q :'$D(^VPR( 560,"AITEM ",DFN))
  21645   "RTN","VPR EVNT",128, 0)
  21646    D POST(DF N,"visit", IEN)
  21647   "RTN","VPR EVNT",129, 0)
  21648    S DA=0 F   S DA=$O(^ TMP("PXKCO ",$J,IEN," IMM",DA))  Q:DA<1  D  POST(DFN," immunizati on",DA)
  21649   "RTN","VPR EVNT",130, 0)
  21650    S DA=0 F   S DA=$O(^ TMP("PXKCO ",$J,IEN," HF",DA)) Q :DA<1  D P OST(DFN,"f actor",DA)
  21651   "RTN","VPR EVNT",131, 0)
  21652    Q
  21653   "RTN","VPR EVNT",132, 0)
  21654    ;
  21655   "RTN","VPR EVNT",133, 0)
  21656   XQOR(MSG)  ; -- messa ging liste ner (updat e meds, la bs, xrays,  consults)
  21657   "RTN","VPR EVNT",134, 0)
  21658    N VPRMSG, VPRPKG,MSH ,ORC,DFN
  21659   "RTN","VPR EVNT",135, 0)
  21660    S VPRMSG= $S($L($G(M SG)):MSG,1 :"MSG") Q: '$O(@VPRMS G@(0))
  21661   "RTN","VPR EVNT",136, 0)
  21662    S MSH=0 F   S MSH=$O (@VPRMSG@( MSH)) Q:MS H'>0  Q:$E (@VPRMSG@( MSH),1,3)= "MSH"
  21663   "RTN","VPR EVNT",137, 0)
  21664    Q:'MSH  Q :'$L($G(@V PRMSG@(MSH )))
  21665   "RTN","VPR EVNT",138, 0)
  21666    S VPRPKG= $$TYPE($P( @VPRMSG@(M SH),"|",3) )  Q:'$L(V PRPKG)
  21667   "RTN","VPR EVNT",139, 0)
  21668    S DFN=$$P ID Q:DFN<1   Q:'$D(^V PR(560,"AI TEM",DFN))
  21669   "RTN","VPR EVNT",140, 0)
  21670    S ORC=MSH  F  S ORC= $O(@VPRMSG @(+ORC)) Q :ORC'>0  I  $E(@VPRMS G@(ORC),1, 3)="ORC" D
  21671   "RTN","VPR EVNT",141, 0)
  21672    . N ORDCN TRL,PKGIFN ,ORIFN
  21673   "RTN","VPR EVNT",142, 0)
  21674    . S ORC=O RC_U_@VPRM SG@(ORC),O RDCNTRL=$T R($P(ORC," |",2),"@", "P")
  21675   "RTN","VPR EVNT",143, 0)
  21676    . ; QUIT  if action  failed, co nversion,  purge, or  backdoor v erify/new
  21677   "RTN","VPR EVNT",144, 0)
  21678    . I ORDCN TRL["U"!(" DE^ZC^ZP^Z R^ZV^SN"[O RDCNTRL) Q
  21679   "RTN","VPR EVNT",145, 0)
  21680    . S ORIFN =+$P($P(OR C,"|",3),U ),PKGIFN=$ P($P(ORC," |",4),U)
  21681   "RTN","VPR EVNT",146, 0)
  21682    . ; if or der has a  parent, us e parent#  and update  entire or der
  21683   "RTN","VPR EVNT",147, 0)
  21684    . S ORIFN =$S($P($G( ^OR(100,OR IFN,3)),U, 9):$P(^(3) ,U,9),1:OR IFN)
  21685   "RTN","VPR EVNT",148, 0)
  21686    . I $$RES ULT D  ;up date ancil lary domai ns
  21687   "RTN","VPR EVNT",149, 0)
  21688    .. D POST (DFN,VPRPK G,PKGIFN)
  21689   "RTN","VPR EVNT",150, 0)
  21690    .. D:VPRP KG="image"  POST(DFN, "document" ,PKGIFN)
  21691   "RTN","VPR EVNT",151, 0)
  21692    .. I VPRP KG="lab",P KGIFN'["CH ",'$$LRTIU (DFN,PKGIF N) D POST( DFN,"docum ent",$P(PK GIFN,";",4 ,5))
  21693   "RTN","VPR EVNT",152, 0)
  21694    . I ORIFN ,ORDCNTRL' ="ZD" D  ; update ord er(s)
  21695   "RTN","VPR EVNT",153, 0)
  21696    .. D POST (DFN,"orde r",ORIFN)
  21697   "RTN","VPR EVNT",154, 0)
  21698    .. N ORIG  S ORIG=+$ P($G(^OR(1 00,ORIFN,3 )),U,5)
  21699   "RTN","VPR EVNT",155, 0)
  21700    .. I ORIG  D POST(DF N,"order", ORIG) ;nee d fwd ptrs , sig flds
  21701   "RTN","VPR EVNT",156, 0)
  21702    Q
  21703   "RTN","VPR EVNT",157, 0)
  21704    ;
  21705   "RTN","VPR EVNT",158, 0)
  21706   RESULT() ;  -- Return  1 or 0, i f message  broadcasts  a result
  21707   "RTN","VPR EVNT",159, 0)
  21708    ;            [may mo dify PKGIF N for use  in POST]
  21709   "RTN","VPR EVNT",160, 0)
  21710    N Y S Y=0
  21711   "RTN","VPR EVNT",161, 0)
  21712    I VPRPKG= "consult"  S Y=1,PKGI FN=+PKGIFN  G RQ
  21713   "RTN","VPR EVNT",162, 0)
  21714    I VPRPKG= "med"      S Y=1,PKGI FN=ORIFN G  RQ
  21715   "RTN","VPR EVNT",163, 0)
  21716    I VPRPKG= "lab"      S:ORDCNTRL ="RE"&($L( PKGIFN,";" )>3) Y=1 G  RQ
  21717   "RTN","VPR EVNT",164, 0)
  21718    I VPRPKG= "image"    S:PKGIFN[" ~" Y=1,PKG IFN=$TR($P (PKGIFN,"~ ",2,3),"~" ,"-") G RQ
  21719   "RTN","VPR EVNT",165, 0)
  21720   RQ Q Y
  21721   "RTN","VPR EVNT",166, 0)
  21722    ;
  21723   "RTN","VPR EVNT",167, 0)
  21724   LRTIU(DFN, ORPK) ; --  Return 1  or 0, if L R report i s in TIU
  21725   "RTN","VPR EVNT",168, 0)
  21726    I $G(DFN) <1!'$L($G( ORPK)) Q 0
  21727   "RTN","VPR EVNT",169, 0)
  21728    I ORPK["C H"!(ORPK[" MI") Q 0
  21729   "RTN","VPR EVNT",170, 0)
  21730    N SUB,IDT ,LRDFN
  21731   "RTN","VPR EVNT",171, 0)
  21732    S SUB=$P( ORPK,";",4 ),IDT=+$P( ORPK,";",5 ),LRDFN=+$ G(^DPT(+DF N,"LR"))
  21733   "RTN","VPR EVNT",172, 0)
  21734    I $O(^LR( LRDFN,SUB, IDT,.05,0) ) Q 1
  21735   "RTN","VPR EVNT",173, 0)
  21736    Q 0
  21737   "RTN","VPR EVNT",174, 0)
  21738    ;
  21739   "RTN","VPR EVNT",175, 0)
  21740   NA(MSG) ;  -- messagi ng listene r (new bac kdoor orde rs)
  21741   "RTN","VPR EVNT",176, 0)
  21742    N VPRMSG, VPRPKG,MSH ,ORC,DFN
  21743   "RTN","VPR EVNT",177, 0)
  21744    S VPRMSG= $S($L($G(M SG)):MSG,1 :"MSG") Q: '$O(@VPRMS G@(0))
  21745   "RTN","VPR EVNT",178, 0)
  21746    S MSH=0 F   S MSH=$O (@VPRMSG@( MSH)) Q:MS H'>0  Q:$E (@VPRMSG@( MSH),1,3)= "MSH"
  21747   "RTN","VPR EVNT",179, 0)
  21748    Q:'MSH  Q :'$L($G(@V PRMSG@(MSH )))
  21749   "RTN","VPR EVNT",180, 0)
  21750    S VPRPKG= $$TYPE($P( @VPRMSG@(M SH),"|",3) )  Q:'$L(V PRPKG)
  21751   "RTN","VPR EVNT",181, 0)
  21752    S DFN=$$P ID Q:DFN<1   Q:'$D(^V PR(560,"AI TEM",DFN))
  21753   "RTN","VPR EVNT",182, 0)
  21754    S ORC=MSH  F  S ORC= $O(@VPRMSG @(+ORC)) Q :ORC'>0  I  $E(@VPRMS G@(ORC),1, 3)="ORC" D
  21755   "RTN","VPR EVNT",183, 0)
  21756    . N ORDCN TRL,ORIFN
  21757   "RTN","VPR EVNT",184, 0)
  21758    . S ORC=O RC_U_@VPRM SG@(ORC),O RDCNTRL=$T R($P(ORC," |",2),"@", "P")
  21759   "RTN","VPR EVNT",185, 0)
  21760    . Q:ORDCN TRL'="NA"
  21761   "RTN","VPR EVNT",186, 0)
  21762    . S ORIFN =+$P($P(OR C,"|",3),U ) D POST(D FN,"order" ,ORIFN)
  21763   "RTN","VPR EVNT",187, 0)
  21764    . I VPRPK G="med" D  POST(DFN,V PRPKG,ORIF N)
  21765   "RTN","VPR EVNT",188, 0)
  21766    Q
  21767   "RTN","VPR EVNT",189, 0)
  21768    ;
  21769   "RTN","VPR EVNT",190, 0)
  21770   TYPE(NAME)  ; -- Retu rns type n ame for XM L
  21771   "RTN","VPR EVNT",191, 0)
  21772    I NAME="L ABORATORY"   Q "lab"
  21773   "RTN","VPR EVNT",192, 0)
  21774    I NAME="P HARMACY"     Q "med"
  21775   "RTN","VPR EVNT",193, 0)
  21776    I NAME="C ONSULTS"     Q "consu lt"
  21777   "RTN","VPR EVNT",194, 0)
  21778    I NAME="P ROCEDURES"   Q "consu lt"
  21779   "RTN","VPR EVNT",195, 0)
  21780    I NAME="R ADIOLOGY"    Q "image "
  21781   "RTN","VPR EVNT",196, 0)
  21782    I NAME="I MAGING"      Q "image "
  21783   "RTN","VPR EVNT",197, 0)
  21784    I NAME="O RDER ENTRY " Q "order "
  21785   "RTN","VPR EVNT",198, 0)
  21786    I NAME="D IETETICS"    Q "diet"
  21787   "RTN","VPR EVNT",199, 0)
  21788    Q ""
  21789   "RTN","VPR EVNT",200, 0)
  21790    ;
  21791   "RTN","VPR EVNT",201, 0)
  21792   PID() ; --  Returns p atient fro m PID segm ent in cur rent msg
  21793   "RTN","VPR EVNT",202, 0)
  21794    N I,SEG,Y  S I=MSH
  21795   "RTN","VPR EVNT",203, 0)
  21796    F  S I=$O (@VPRMSG@( I)) Q:I'>0   S SEG=$E (@VPRMSG@( I),1,3) Q: SEG="ORC"   I SEG="PI D" D  Q
  21797   "RTN","VPR EVNT",204, 0)
  21798    . S Y=+$P (@VPRMSG@( I),"|",4)
  21799   "RTN","VPR EVNT",205, 0)
  21800    .;I '$D(^ DPT(Y,0))  S:$L($P(@V PRMSG@(I), "|",5)) Y= +$P(@VPRMS G@(I),"|", 5) ;alt ID  for Lab
  21801   "RTN","VPR EVNT",206, 0)
  21802    Q Y
  21803   "RTN","VPR EVNT",207, 0)
  21804    ;
  21805   "RTN","VPR EVNT",208, 0)
  21806   PV1() ; --  Returns p atient cla ss from PV 1 segment  in current  msg
  21807   "RTN","VPR EVNT",209, 0)
  21808    N I,SEG,Y  S I=MSH,Y =""
  21809   "RTN","VPR EVNT",210, 0)
  21810    F  S I=$O (@VPRMSG@( I)) Q:I'>0   S SEG=$E (@VPRMSG@( I),1,3) Q: SEG="ORC"   I SEG="PV 1" D  Q
  21811   "RTN","VPR EVNT",211, 0)
  21812    . S Y=$P( @VPRMSG@(I ),"|",3)
  21813   "RTN","VPR EVNT",212, 0)
  21814    I Y="",$G (ORIFN) S  Y=$$GET1^D IQ(100,+OR IFN_",",10 ,"I")
  21815   "RTN","VPR EVNT",213, 0)
  21816    Q Y
  21817   "RTN","VPR EVNT",214, 0)
  21818    ;
  21819   "RTN","VPR EVNT",215, 0)
  21820   GMRA(ACT)  ; -- GMRA  SIGN-OFF O N DATA pro tocol list ener
  21821   "RTN","VPR EVNT",216, 0)
  21822    ;   also  GMRA ENTER ED IN ERRO R [ACT=@]
  21823   "RTN","VPR EVNT",217, 0)
  21824    N DFN,IEN
  21825   "RTN","VPR EVNT",218, 0)
  21826    S DFN=+$G (GMRAPA(0) ),IEN=+$G( GMRAPA)
  21827   "RTN","VPR EVNT",219, 0)
  21828    D POST(DF N,"allergy ",IEN,$G(A CT))
  21829   "RTN","VPR EVNT",220, 0)
  21830    Q
  21831   "RTN","VPR EVNT",221, 0)
  21832    ;
  21833   "RTN","VPR EVNT",222, 0)
  21834   GMPL(DFN,I EN) ; -- G MPL EVENT  protocol l istener
  21835   "RTN","VPR EVNT",223, 0)
  21836    S DFN=+$G (DFN),IEN= +$G(IEN)
  21837   "RTN","VPR EVNT",224, 0)
  21838    ;N ACT S  ACT=$S($P( $G(^AUPNPR OB(IEN,1)) ,U,2)="H": "@",1:"")
  21839   "RTN","VPR EVNT",225, 0)
  21840    D POST(DF N,"problem ",IEN) ;,A CT)
  21841   "RTN","VPR EVNT",226, 0)
  21842    Q
  21843   "RTN","VPR EVNT",227, 0)
  21844    ;
  21845   "RTN","VPR EVNT",228, 0)
  21846   GMRV(DFN,I EN,ERR) ;  -- Vital M easurement  file #120 .5 AVPR in dex
  21847   "RTN","VPR EVNT",229, 0)
  21848    S DFN=+$G (DFN),IEN= +$G(IEN)
  21849   "RTN","VPR EVNT",230, 0)
  21850    ;. N VPRY
  21851   "RTN","VPR EVNT",231, 0)
  21852    ;. D GETR EC^GMVUTL( .VPRY,IEN, 1) ;use Da te Taken i nstead,
  21853   "RTN","VPR EVNT",232, 0)
  21854    ;. I $G(V PRY(0)) S  IEN=+VPRY( 0) ; to ge t all rela ted result s
  21855   "RTN","VPR EVNT",233, 0)
  21856    N ACT S A CT=$S($G(E RR):"@",1: "")
  21857   "RTN","VPR EVNT",234, 0)
  21858    D POST(DF N,"vital", IEN,ACT)
  21859   "RTN","VPR EVNT",235, 0)
  21860    Q
  21861   "RTN","VPR EVNT",236, 0)
  21862    ;
  21863   "RTN","VPR EVNT",237, 0)
  21864   MDC(OBS) ;  -- CLiO O BS file #7 04.117
  21865   "RTN","VPR EVNT",238, 0)
  21866    N DFN,ID, ACT
  21867   "RTN","VPR EVNT",239, 0)
  21868    S DFN=+$G (OBS("PATI ENT_ID","I ")) Q:DFN< 1
  21869   "RTN","VPR EVNT",240, 0)
  21870    S ID=$G(O BS("OBS_ID ","I")) Q: '$L(ID)
  21871   "RTN","VPR EVNT",241, 0)
  21872    S ACT=$S( '$G(OBS("S TATUS","I" )):"@",1:" ")
  21873   "RTN","VPR EVNT",242, 0)
  21874    D POST(DF N,"obs",ID ,ACT)
  21875   "RTN","VPR EVNT",243, 0)
  21876    I $G(OBS( "DOMAIN"," VITALS"))  D POST(DFN ,"vital",I D,ACT)
  21877   "RTN","VPR EVNT",244, 0)
  21878    Q
  21879   "RTN","VPR EVNT",245, 0)
  21880    ;
  21881   "RTN","VPR EVNT",246, 0)
  21882   CP(DFN,ID, ACT) ; --  CP Transac tion file  #702 AVPR  index
  21883   "RTN","VPR EVNT",247, 0)
  21884    S DFN=+$G (DFN),ID=$ G(ID)
  21885   "RTN","VPR EVNT",248, 0)
  21886    D POST(DF N,"procedu re",ID,$G( ACT))
  21887   "RTN","VPR EVNT",249, 0)
  21888    Q
  21889   "RTN","VPR EVNT",250, 0)
  21890    ;
  21891   "RTN","VPR EVNT",251, 0)
  21892   SR(DFN,IEN ,ACT) ; --  Surgery [ SROERR] up date
  21893   "RTN","VPR EVNT",252, 0)
  21894    S DFN=+$G (DFN),IEN= +$G(IEN)
  21895   "RTN","VPR EVNT",253, 0)
  21896    D POST(DF N,"surgery ",IEN,$G(A CT))
  21897   "RTN","VPR EVNT",254, 0)
  21898    Q
  21899   "RTN","VPR EVNT",255, 0)
  21900    ;
  21901   "RTN","VPR EVNT",256, 0)
  21902   TIU(DFN,IE N) ; -- TI U Document  file #892 5 AVPR ind ex
  21903   "RTN","VPR EVNT",257, 0)
  21904    N ACT
  21905   "RTN","VPR EVNT",258, 0)
  21906    S DFN=+$G (DFN),IEN= +$G(IEN),A CT=""
  21907   "RTN","VPR EVNT",259, 0)
  21908    ; $$ISADD NDM^TIULC1 (IEN) S IE N=+$$GET1^ DIQ(8925,I EN_",",.06 ,"I")
  21909   "RTN","VPR EVNT",260, 0)
  21910    N VPRX S  VPRX=$$RES OLVE^TIUSR VLO(IEN)
  21911   "RTN","VPR EVNT",261, 0)
  21912    I $P(VPRX ,U,13),$P( $P(VPRX,U) ," ")="Add endum" S I EN=$P(VPRX ,U,13)
  21913   "RTN","VPR EVNT",262, 0)
  21914    I $P(VPRX ,U,6)="ret racted" S  ACT="@"
  21915   "RTN","VPR EVNT",263, 0)
  21916    D POST(DF N,"documen t",IEN,ACT )
  21917   "RTN","VPR EVNT",264, 0)
  21918    Q
  21919   "RTN","VPR EVNT",265, 0)
  21920    ;
  21921   "RTN","VPR EVNT",266, 0)
  21922   PSB ; -- V PR PSB EVE NTS protoc ol listene r (BCMA)
  21923   "RTN","VPR EVNT",267, 0)
  21924    N IEN,DFN ,ORPK,TYPE ,ORIFN
  21925   "RTN","VPR EVNT",268, 0)
  21926    S IEN=$S( $P($G(PSBI EN),",",2) '="":+$P(P SBIEN,",", 2),$G(PSBI EN)="+1":+ $G(PSBIEN( 1)),1:+$G( PSBIEN))
  21927   "RTN","VPR EVNT",269, 0)
  21928    S DFN=+$G (^PSB(53.7 9,IEN,0)), ORPK=$P($G (^(.1)),U)
  21929   "RTN","VPR EVNT",270, 0)
  21930    Q:DFN<1   Q:ORPK<1   S TYPE=$S( ORPK["V":" IV",ORPK[" U":5,1:"")  Q:TYPE=""
  21931   "RTN","VPR EVNT",271, 0)
  21932    S ORIFN=+ $P($G(^PS( 55,DFN,TYP E,+ORPK,0) ),U,21)
  21933   "RTN","VPR EVNT",272, 0)
  21934    D:ORIFN P OST(DFN,"m ed",ORIFN)
  21935   "RTN","VPR EVNT",273, 0)
  21936    Q
  21937   "RTN","VPR EVNT",274, 0)
  21938    ;
  21939   "RTN","VPR EVNT",275, 0)
  21940   XU(IEN,ACT ) ; -- XU  USER ADD/C HANGE/TERM INATE opti on listene r
  21941   "RTN","VPR EVNT",276, 0)
  21942    S IEN=+$G (IEN) Q:IE N<1
  21943   "RTN","VPR EVNT",277, 0)
  21944    D POSTX(" user",IEN, $G(ACT))
  21945   "RTN","VPR EVNT",278, 0)
  21946    Q
  21947   "RTN","VPR EVNT",279, 0)
  21948    ;
  21949   "RTN","VPR EVNT",280, 0)
  21950   POST(DFN,T YPE,ID,ACT ) ; -- tra ck updated  patient d ata
  21951   "RTN","VPR EVNT",281, 0)
  21952    S DFN=+$G (DFN),TYPE =$G(TYPE), ID=$G(ID)
  21953   "RTN","VPR EVNT",282, 0)
  21954    Q:DFN<1   Q:TYPE=""   Q:ID=""    ;incomple te request
  21955   "RTN","VPR EVNT",283, 0)
  21956    Q:$G(^XTM P("VPR-off ",TYPE))    ;domain t urned 'off '
  21957   "RTN","VPR EVNT",284, 0)
  21958    Q:'$D(^VP R(560,"AIT EM",DFN))   ;patient  not subscr ibed to
  21959   "RTN","VPR EVNT",285, 0)
  21960    N VPRDT S  VPRDT="VP R-"_DT
  21961   "RTN","VPR EVNT",286, 0)
  21962    ;S ^XTMP( VPRDT,$$NE XT)=DFN_U_ TYPE_U_ID_ U_$G(ACT)
  21963   "RTN","VPR EVNT",287, 0)
  21964    N NODES
  21965   "RTN","VPR EVNT",288, 0)
  21966    D POST^VP RDJFS(DFN, TYPE,ID,$G (ACT),"",. NODES)
  21967   "RTN","VPR EVNT",289, 0)
  21968    Q
  21969   "RTN","VPR EVNT",290, 0)
  21970    ;
  21971   "RTN","VPR EVNT",291, 0)
  21972   POSTX(TYPE ,ID,ACT) ;  -- track  updated re ference it ems
  21973   "RTN","VPR EVNT",292, 0)
  21974    S TYPE=$G (TYPE),ID= $G(ID)
  21975   "RTN","VPR EVNT",293, 0)
  21976    Q:TYPE=""   Q:ID=""              ;incomple te request
  21977   "RTN","VPR EVNT",294, 0)
  21978    Q:$G(^XTM P("VPR-off ",TYPE))    ;domain t urned 'off '
  21979   "RTN","VPR EVNT",295, 0)
  21980    N VPRDT S  VPRDT="VP R-"_DT ;"V PREF-"_DT
  21981   "RTN","VPR EVNT",296, 0)
  21982    ;S ^XTMP( VPRDT,$$NE XT)=U_TYPE _U_ID_U_$G (ACT)
  21983   "RTN","VPR EVNT",297, 0)
  21984    N NODES
  21985   "RTN","VPR EVNT",298, 0)
  21986    D POST^VP RDJFS("OPD ",TYPE,ID, $G(ACT),"" ,.NODES)
  21987   "RTN","VPR EVNT",299, 0)
  21988    Q
  21989   "RTN","VPR EVNT",300, 0)
  21990    ;
  21991   "RTN","VPR EVNT",301, 0)
  21992   NEXT() ; - - Return n ext sequen tial numbe r in ^XTMP (VPRDT,n)
  21993   "RTN","VPR EVNT",302, 0)
  21994    L +^XTMP( VPRDT):5 ; I'$T ??
  21995   "RTN","VPR EVNT",303, 0)
  21996    N Y S Y=+ $O(^XTMP(V PRDT,"A"), -1)+1
  21997   "RTN","VPR EVNT",304, 0)
  21998    I '$D(^XT MP(VPRDT,0 )) S ^(0)= $$FMADD^XL FDT(DT,3)_ U_DT_"^VPR  Updates"
  21999   "RTN","VPR EVNT",305, 0)
  22000    L -^XTMP( VPRDT)
  22001   "RTN","VPR EVNT",306, 0)
  22002    Q Y
  22003   "RTN","VPR EVNT",307, 0)
  22004    ;
  22005   "RTN","VPR EVNT",308, 0)
  22006   HTTP(URL,D FN,TYPE,ID ) ; -- sen d message  that TYPE/ ID has bee n updated  [not in us e]
  22007   "RTN","VPR EVNT",309, 0)
  22008    N DIV,X,V PRX
  22009   "RTN","VPR EVNT",310, 0)
  22010    S DFN=+$G (DFN) Q:DF N<1  ;pati ent req'd
  22011   "RTN","VPR EVNT",311, 0)
  22012    S DIV=$P( $$SITE^VAS ITE,U,3) ; station nu mber
  22013   "RTN","VPR EVNT",312, 0)
  22014    S URL=$G( URL)_"?div ision="_DI V_"&dfn="_ +$G(DFN)
  22015   "RTN","VPR EVNT",313, 0)
  22016    I $L($G(T YPE)) S UR L=URL_"&ty pe="_TYPE
  22017   "RTN","VPR EVNT",314, 0)
  22018    I $L($G(I D))   S UR L=URL_"&id ="_ID
  22019   "RTN","VPR EVNT",315, 0)
  22020    S ^XTMP(" VPR",DFN," HTTP")=$H
  22021   "RTN","VPR EVNT",316, 0)
  22022    S X=$$GET URL^XTHC10 (URL,,"VPR X")
  22023   "RTN","VPR EVNT",317, 0)
  22024    ; I X>200  = ERROR
  22025   "RTN","VPR EVNT",318, 0)
  22026    Q
  22027   "RTN","VPR FPTC")
  22028   0^12^B1457 6966
  22029   "RTN","VPR FPTC",1,0)
  22030   VPRFPTC ;S LC/MKB,AGP  - Patient  look-up U tilities a t Facility  ; 6/06/12
  22031   "RTN","VPR FPTC",2,0)
  22032    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  22033   "RTN","VPR FPTC",3,0)
  22034    ;
  22035   "RTN","VPR FPTC",4,0)
  22036   CHKS(VPRZ, DFN) ; per form patie nt select  checks
  22037   "RTN","VPR FPTC",5,0)
  22038    ;
  22039   "RTN","VPR FPTC",6,0)
  22040    N ACCESS, CHKS,CNT,E RR,I,IEN,S TR,X,VPRY
  22041   "RTN","VPR FPTC",7,0)
  22042    ; check f or sensiti ve record
  22043   "RTN","VPR FPTC",8,0)
  22044    S STR="pa tientCheck s"
  22045   "RTN","VPR FPTC",9,0)
  22046    S ACCESS= 0
  22047   "RTN","VPR FPTC",10,0 )
  22048    D PTSEC^D GSEC4(.VPR Y,DFN)  ;I A #3027
  22049   "RTN","VPR FPTC",11,0 )
  22050    S ACCESS= 1
  22051   "RTN","VPR FPTC",12,0 )
  22052    I VPRY(1) >0 D
  22053   "RTN","VPR FPTC",13,0 )
  22054    .S CHKS(" sensitive" ,"dfn")=DF N
  22055   "RTN","VPR FPTC",14,0 )
  22056    .S ACCESS =(VPRY(1)< 3)
  22057   "RTN","VPR FPTC",15,0 )
  22058    .S CHKS(" sensitive" ,"mayAcces s")=$S(ACC ESS=1:"tru e",1:"fals e")
  22059   "RTN","VPR FPTC",16,0 )
  22060    .S CHKS(" sensitive" ,"logAcces s")=$S(VPR Y(1)>1:"tr ue",1:"fal se")
  22061   "RTN","VPR FPTC",17,0 )
  22062    .S CNT=2, X=""
  22063   "RTN","VPR FPTC",18,0 )
  22064    .F  S CNT =$O(VPRY(C NT)) Q:CNT '>0  S X=X _$C(13)_$C (10)_$G(VP RY(CNT))
  22065   "RTN","VPR FPTC",19,0 )
  22066    .S CHKS(" sensitive" ,"text")=X
  22067   "RTN","VPR FPTC",20,0 )
  22068    ;
  22069   "RTN","VPR FPTC",21,0 )
  22070    ; check f or decease d patient
  22071   "RTN","VPR FPTC",22,0 )
  22072    I +$G(^DP T(DFN,.35) ) D
  22073   "RTN","VPR FPTC",23,0 )
  22074    . S CHKS( "deceased" ,"text")=" This patie nt died on  "_$$FMTE^ XLFDT(^DPT (DFN,.35), "D")_"."_$ C(13)_$C(1 0)_" Do yo u wish to  continue?"
  22075   "RTN","VPR FPTC",24,0 )
  22076    ;
  22077   "RTN","VPR FPTC",25,0 )
  22078    ; check f or similar  patients
  22079   "RTN","VPR FPTC",26,0 )
  22080    K VPRY
  22081   "RTN","VPR FPTC",27,0 )
  22082    N MSG,SIM ,SIMPAT,TE XT S MSG=0 ,SIM=0
  22083   "RTN","VPR FPTC",28,0 )
  22084    D GUIBS5A ^DPTLK6(.V PRY,DFN)   ;IA #3593
  22085   "RTN","VPR FPTC",29,0 )
  22086    I VPRY(1) >0 D
  22087   "RTN","VPR FPTC",30,0 )
  22088    .S TEXT=" "
  22089   "RTN","VPR FPTC",31,0 )
  22090    .S I=1 F   S I=$O(VP RY(I)) Q:' I  S X=VPR Y(I) D
  22091   "RTN","VPR FPTC",32,0 )
  22092    .. S SIM= SIM+1
  22093   "RTN","VPR FPTC",33,0 )
  22094    .. I $E(X )=0 S TEXT =$S($L(TEX T):TEXT_$C (13)_$C(10 )_$P(X,U,2 ),1:$P(X,U ,2))
  22095   "RTN","VPR FPTC",34,0 )
  22096    .. I $E(X )=1 D
  22097   "RTN","VPR FPTC",35,0 )
  22098    ... ;S CH KS("simila r",SIM,"df n")=$P(X,U ,2)
  22099   "RTN","VPR FPTC",36,0 )
  22100    ... ;S CH KS("simila r",SIM,"na me")=$P(X, U,3)
  22101   "RTN","VPR FPTC",37,0 )
  22102    ... ;S CH KS("simila r",SIM,"do b")=$$FMTE ^XLFDT($P( X,U,4),"D" )
  22103   "RTN","VPR FPTC",38,0 )
  22104    ... ;S CH KS("simila r",SIM,"ss n")=$P(X,U ,5)
  22105   "RTN","VPR FPTC",39,0 )
  22106    ... S SIM PAT="Patie nt Name: " _$P(X,U,3) _" Date of  Birth: "_ $$FMTE^XLF DT($P(X,U, 4),"D")_"  SSN: "_$P( X,U,5)
  22107   "RTN","VPR FPTC",40,0 )
  22108    ... S TEX T=TEXT_$C( 13)_$C(10) _SIMPAT
  22109   "RTN","VPR FPTC",41,0 )
  22110    .S CHKS(" similar"," text")=TEX T
  22111   "RTN","VPR FPTC",42,0 )
  22112    ;
  22113   "RTN","VPR FPTC",43,0 )
  22114    ; possibl y check me ans test:  GUIMTD^DPT LK6
  22115   "RTN","VPR FPTC",44,0 )
  22116    ; possibl y check le gacy data:  I $L($T(H XDATA^A7RD PAGU)...
  22117   "RTN","VPR FPTC",45,0 )
  22118    ;
  22119   "RTN","VPR FPTC",46,0 )
  22120    I ACCESS  D PRF(DFN, .CHKS)
  22121   "RTN","VPR FPTC",47,0 )
  22122    S ERR(0)= ""
  22123   "RTN","VPR FPTC",48,0 )
  22124    ;S VPR=$$ ENCODE^VPR JSON("CHKS ","ERR")
  22125   "RTN","VPR FPTC",49,0 )
  22126    D ENCODE^ VPRJSON("C HKS","VPRZ ","ERR")
  22127   "RTN","VPR FPTC",50,0 )
  22128    Q
  22129   "RTN","VPR FPTC",51,0 )
  22130    ;
  22131   "RTN","VPR FPTC",52,0 )
  22132   PRF(DFN,CH KS) ; get  Patient Re cord Flags
  22133   "RTN","VPR FPTC",53,0 )
  22134    N VPRY,ED I,PRF,N,X
  22135   "RTN","VPR FPTC",54,0 )
  22136    Q:$$GETAC T^DGPFAPI( DFN,"VPRY" )'>0
  22137   "RTN","VPR FPTC",55,0 )
  22138    S EDI=0 F   S EDI=$O (VPRY(EDI) ) Q:EDI<1   K PRF D
  22139   "RTN","VPR FPTC",56,0 )
  22140    . S CHKS( "patientRe cordFlags" ,EDI,"assi gnmentStat us")="Acti ve"
  22141   "RTN","VPR FPTC",57,0 )
  22142    . S CHKS( "patientRe cordFlags" ,EDI,"assi gnTS")=$$J SONDT^VPRU TILS($P($G (VPRY(EDI, "ASSIGNDT" )),U))
  22143   "RTN","VPR FPTC",58,0 )
  22144    . S CHKS( "patientRe cordFlags" ,EDI,"appr oved")=$P( $G(VPRY(ED I,"APPRVBY ")),U,2)
  22145   "RTN","VPR FPTC",59,0 )
  22146    . S CHKS( "patientRe cordFlags" ,EDI,"next ReviewDT") =$$JSONDT^ VPRUTILS($ P($G(VPRY( EDI,"REVIE WDT")),U))
  22147   "RTN","VPR FPTC",60,0 )
  22148    . S CHKS( "patientRe cordFlags" ,EDI,"name ")=$P($G(V PRY(EDI,"F LAG")),U,2 )
  22149   "RTN","VPR FPTC",61,0 )
  22150    . S CHKS( "patientRe cordFlags" ,EDI,"type ")=$P($G(V PRY(EDI,"F LAGTYPE")) ,U,2)
  22151   "RTN","VPR FPTC",62,0 )
  22152    . S CHKS( "patientRe cordFlags" ,EDI,"cate gory")=$P( $G(VPRY(ED I,"CATEGOR Y")),U,2)
  22153   "RTN","VPR FPTC",63,0 )
  22154    . S CHKS( "patientRe cordFlags" ,EDI,"owne rSite")=$P ($G(VPRY(E DI,"OWNER" )),U,2)
  22155   "RTN","VPR FPTC",64,0 )
  22156    . S CHKS( "patientRe cordFlags" ,EDI,"orig inatingSit e")=$P($G( VPRY(EDI," ORIGSITE") ),U,2)
  22157   "RTN","VPR FPTC",65,0 )
  22158    . S N=1,X =$G(VPRY(E DI,"NARR", 1,0))
  22159   "RTN","VPR FPTC",66,0 )
  22160    . F  S N= $O(VPRY(ED I,"NARR",N )) Q:N<1   S X=X_$C(1 3)_$C(10)_ $G(VPRY(ED I,"NARR",N ,0))
  22161   "RTN","VPR FPTC",67,0 )
  22162    . S CHKS( "patientRe cordFlags" ,EDI,"text ")=X
  22163   "RTN","VPR FPTC",68,0 )
  22164    Q
  22165   "RTN","VPR FPTC",69,0 )
  22166    ;
  22167   "RTN","VPR FPTC",70,0 )
  22168   LOG(VPRZ,D FN) ; Make  entry in  security l og for sen sitive pat ient acces s
  22169   "RTN","VPR FPTC",71,0 )
  22170    N ERR,RES ULTS,VPRY, X
  22171   "RTN","VPR FPTC",72,0 )
  22172    D NOTICE^ DGSEC4(.VP RY,DFN) ;I A #3027
  22173   "RTN","VPR FPTC",73,0 )
  22174    S X=$S(VP RY:"ok",1: "fail")
  22175   "RTN","VPR FPTC",74,0 )
  22176    S RESULTS ("result") =X
  22177   "RTN","VPR FPTC",75,0 )
  22178    ;S VPR=$$ ENCODE^VPR JSON("RESU LTS","ERR" )
  22179   "RTN","VPR FPTC",76,0 )
  22180    D ENCODE^ VPRJSON("R ESULTS","V PRZ","ERR" )
  22181   "RTN","VPR FPTC",77,0 )
  22182    Q
  22183   "RTN","VPR FPTC",78,0 )
  22184    ;
  22185   "RTN","VPR FPTC",79,0 )
  22186   ENROS(VPRZ ,DFNARRAY)  ;PROCESS  PATIENTS F ROM A ROST ER
  22187   "RTN","VPR FPTC",80,0 )
  22188    N DFN S D FN=0
  22189   "RTN","VPR FPTC",81,0 )
  22190    F  S DFN= $O(DFNARRA Y(DFN)) Q: DFN'>0  D  CHKS(.VPRZ ,DFN)
  22191   "RTN","VPR FPTC",82,0 )
  22192    Q
  22193   "RTN","VPR FPTC",83,0 )
  22194    ;
  22195   "RTN","VPR FPTC",84,0 )
  22196   TEST ; 
  22197   "RTN","VPR FPTC",85,0 )
  22198    S EDPSITE =$$IEN^XUA F4(442),NA ME="doe,jo hn"
  22199   "RTN","VPR FPTC",86,0 )
  22200    D CHKS(1, "",NAME)
  22201   "RTN","VPR FPTC",87,0 )
  22202    ;N PID S  EDPSITE=$$ IEN^XUAF4( 442)
  22203   "RTN","VPR FPTC",88,0 )
  22204    ;R "DFN:" ,PID Q:PID =""  W !
  22205   "RTN","VPR FPTC",89,0 )
  22206    ;D CHK(1, PID,$P(^DP T(PID,0),U ))
  22207   "RTN","VPR FPTC",90,0 )
  22208    N I S I=0  F  S I=$O (EDPXML(I) ) Q:'I  W  !,EDPXML(I )
  22209   "RTN","VPR FPTC",91,0 )
  22210    K EDPXML
  22211   "RTN","VPR FPTC",92,0 )
  22212    Q
  22213   "RTN","VPR FPTC",93,0 )
  22214   TEST1 ;
  22215   "RTN","VPR FPTC",94,0 )
  22216    S EDPSITE =$$IEN^XUA F4(442),NA ME="doe,jo hn"
  22217   "RTN","VPR FPTC",95,0 )
  22218    D CHKS(1, "",NAME)
  22219   "RTN","VPR FPTC",96,0 )
  22220    ;
  22221   "RTN","VPR FPTC",97,0 )
  22222    ;DO LATER ?  -- link ed progres s notes
  22223   "RTN","VPR FPTC",98,0 )
  22224    ;D GETTIT LE^TIUPRF2 (.EDPT,DFN ,EDI),GETN OTES^TIUPR F2(.EDPN,D FN,EDPT,1)
  22225   "RTN","VPR FPTC",99,0 )
  22226    ;I $O(EDP N(0)) D
  22227   "RTN","VPR FPTC",100, 0)
  22228    ;. D XML^ EDPX("<not es>")
  22229   "RTN","VPR FPTC",101, 0)
  22230    ;. S N=0  F  S N=$O( EDPN(N)) Q :N<1  K PN  S X=EDPN( N) D
  22231   "RTN","VPR FPTC",102, 0)
  22232    ;.. S PN( "id")=+X,P N("action" )=$P(X,U,2 ),PN("auth or")=$P(X, U,4)
  22233   "RTN","VPR FPTC",103, 0)
  22234    ;.. S PN( "noteTS")= 9999999-N
  22235   "RTN","VPR FPTC",104, 0)
  22236    ;.. D TGE T^TIUSRVR1 (.EDPX,+X)
  22237   "RTN","VPR FPTC",105, 0)
  22238    ;.. S X=$ $XMLA^EDPX ("note",.P N),X=$TR(X ,"/") D XM L^EDPX(X)
  22239   "RTN","VPR FPTC",106, 0)
  22240    ;.. S I=1 ,X=$G(@EDP X@(1))
  22241   "RTN","VPR FPTC",107, 0)
  22242    ;.. F  S  I=$O(@EDPX @(I)) Q:I< 1  S X=X_$ C(13,10)_$ G(@EDPX@(I ))
  22243   "RTN","VPR FPTC",108, 0)
  22244    ;.. S X=" <text>"_$$ ESC^EDPX(X )_"</text> " D XML^ED PX(X)
  22245   "RTN","VPR FPTC",109, 0)
  22246    ;.. D XML ^EDPX("</n ote>")
  22247   "RTN","VPR FPTC",110, 0)
  22248    ;. D XML^ EDPX("</no tes>")
  22249   "RTN","VPR HTTP")
  22250   0^5^B14174 140
  22251   "RTN","VPR HTTP",1,0)
  22252   VPRHTTP ;S LC/MKB --  HTTP inter face
  22253   "RTN","VPR HTTP",2,0)
  22254    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  22255   "RTN","VPR HTTP",3,0)
  22256    ;
  22257   "RTN","VPR HTTP",4,0)
  22258    ; Externa l Referenc es           DBIA#
  22259   "RTN","VPR HTTP",5,0)
  22260    ; ------- ---------- --           -----
  22261   "RTN","VPR HTTP",6,0)
  22262    ; %ZTLOAD                         10063
  22263   "RTN","VPR HTTP",7,0)
  22264    ; DIR                             10026
  22265   "RTN","VPR HTTP",8,0)
  22266    ; VASITE                          10112
  22267   "RTN","VPR HTTP",9,0)
  22268    ; XLFCRC                           3156
  22269   "RTN","VPR HTTP",10,0 )
  22270    ; XLFUTL                           2622
  22271   "RTN","VPR HTTP",11,0 )
  22272    ; XPAR                             2263
  22273   "RTN","VPR HTTP",12,0 )
  22274    ; XTHC10                           5515
  22275   "RTN","VPR HTTP",13,0 )
  22276    ; XUPARAM                          2541
  22277   "RTN","VPR HTTP",14,0 )
  22278    ;
  22279   "RTN","VPR HTTP",15,0 )
  22280   EN ; -- ma nage the b ackground  job
  22281   "RTN","VPR HTTP",16,0 )
  22282    N ZTSK,ST S
  22283   "RTN","VPR HTTP",17,0 )
  22284    S ZTSK=+$ G(^XTMP("V PR","ZTSK" )),STS=$$S TS
  22285   "RTN","VPR HTTP",18,0 )
  22286    W !,?24," --- VPR Pa tient Data  Monitor - --"
  22287   "RTN","VPR HTTP",19,0 )
  22288    W !!,"Tas k"_$S(ZTSK :" #"_ZTSK ,1:"")_" i s "_$P(STS ,U,2)_".", !
  22289   "RTN","VPR HTTP",20,0 )
  22290    ;
  22291   "RTN","VPR HTTP",21,0 )
  22292    I ZTSK,+S TS=1!(+STS =2) D:$$ST OP  Q
  22293   "RTN","VPR HTTP",22,0 )
  22294    . N X S X =$$ASKSTOP ^%ZTLOAD(Z TSK)
  22295   "RTN","VPR HTTP",23,0 )
  22296    . W !,$P( X,U,2),!
  22297   "RTN","VPR HTTP",24,0 )
  22298    ;
  22299   "RTN","VPR HTTP",25,0 )
  22300    I $$START  D
  22301   "RTN","VPR HTTP",26,0 )
  22302    . W !!,"S tarting VP R Patient  Data Monit or ... " D  QUE
  22303   "RTN","VPR HTTP",27,0 )
  22304    . I $G(ZT SK) W "tas k #"_ZTSK_ " started. ",!
  22305   "RTN","VPR HTTP",28,0 )
  22306    . E  W !, "ERROR: ta sk NOT cre ated.  Try  again lat er.",!
  22307   "RTN","VPR HTTP",29,0 )
  22308    . S ^XTMP ("VPR","ZT SK")=$G(ZT SK)
  22309   "RTN","VPR HTTP",30,0 )
  22310    Q
  22311   "RTN","VPR HTTP",31,0 )
  22312    ;
  22313   "RTN","VPR HTTP",32,0 )
  22314   STS() ; --  get the s tatus of Z TSK
  22315   "RTN","VPR HTTP",33,0 )
  22316    D STAT^%Z TLOAD
  22317   "RTN","VPR HTTP",34,0 )
  22318    N Y S Y=+ $G(ZTSK(1) )_U_$G(ZTS K(2))
  22319   "RTN","VPR HTTP",35,0 )
  22320    Q Y
  22321   "RTN","VPR HTTP",36,0 )
  22322    ;
  22323   "RTN","VPR HTTP",37,0 )
  22324   STOP() ; - - stop the  task?
  22325   "RTN","VPR HTTP",38,0 )
  22326    N X,Y,DIR
  22327   "RTN","VPR HTTP",39,0 )
  22328    S DIR("A" )="Do you  want to st op the dat a monitor?  ",DIR(0)= "YA",DIR(" B")="NO"
  22329   "RTN","VPR HTTP",40,0 )
  22330    S DIR("?" ,1)="Enter  YES to st op or canc el the dat a monitor;  please re start ASAP !"
  22331   "RTN","VPR HTTP",41,0 )
  22332    S DIR("?" ,3)="This  job must b e running  in the bac kground fo r AViVA to  be notifi ed"
  22333   "RTN","VPR HTTP",42,0 )
  22334    S DIR("?" )="when ne w patient  data is av ailable.", DIR("?",2) ="  "
  22335   "RTN","VPR HTTP",43,0 )
  22336    D ^DIR S: Y<1 Y=0
  22337   "RTN","VPR HTTP",44,0 )
  22338    Q Y
  22339   "RTN","VPR HTTP",45,0 )
  22340    ;
  22341   "RTN","VPR HTTP",46,0 )
  22342   START() ;  -- [re]sta rt the tas k?
  22343   "RTN","VPR HTTP",47,0 )
  22344    N X,Y,DIR
  22345   "RTN","VPR HTTP",48,0 )
  22346    S DIR(0)= "YA",DIR(" B")="YES"
  22347   "RTN","VPR HTTP",49,0 )
  22348    S DIR("A" )="Do you  want to "_ $S(STS:"re ",1:"")_"s tart the d ata monito r? "
  22349   "RTN","VPR HTTP",50,0 )
  22350    S DIR("?" ,1)="Enter  YES to "_ $S(STS:"re ",1:"")_"s tart the V PR Patient  Data Moni tor."
  22351   "RTN","VPR HTTP",51,0 )
  22352    S DIR("?" ,3)="This  job must b e running  in the bac kground fo r AViVA to  be notifi ed"
  22353   "RTN","VPR HTTP",52,0 )
  22354    S DIR("?" )="when ne w patient  data is av ailable.", DIR("?",2) ="  "
  22355   "RTN","VPR HTTP",53,0 )
  22356    D ^DIR S: Y<1 Y=0
  22357   "RTN","VPR HTTP",54,0 )
  22358    Q Y
  22359   "RTN","VPR HTTP",55,0 )
  22360    ;
  22361   "RTN","VPR HTTP",56,0 )
  22362   QUE ; -- c reate the  background  task: ret urns ZTSK
  22363   "RTN","VPR HTTP",57,0 )
  22364    N IO,IOP, ZTRTN,ZTDE SC,ZTDTH,Z TIO,ZTUCI, ZTCPU,ZTPR I,ZTKIL,ZT SYNC,ZTSAV E,%ZIS
  22365   "RTN","VPR HTTP",58,0 )
  22366    S %ZIS="0 H",IOP="NU LL" D ^%ZI S I POP W  !,"Null De vice Not F ound" Q
  22367   "RTN","VPR HTTP",59,0 )
  22368    S ZTDESC= "VPR new d ata monito r for AViV A",ZTDTH=$ H,ZTIO=""
  22369   "RTN","VPR HTTP",60,0 )
  22370    S ZTRTN=" POKE^VPRHT TP" K ZTSK
  22371   "RTN","VPR HTTP",61,0 )
  22372    D ^%ZTLOA D
  22373   "RTN","VPR HTTP",62,0 )
  22374    Q
  22375   "RTN","VPR HTTP",63,0 )
  22376    ;
  22377   "RTN","VPR HTTP",64,0 )
  22378   POKE ; --  background  job to po ke the cli ent when n ew data is  available
  22379   "RTN","VPR HTTP",65,0 )
  22380    ; ^XTMP(" VPR",DFN,T YPE,ID) =  new data s ince last  update
  22381   "RTN","VPR HTTP",66,0 )
  22382    N DIV,ID, DFN,DATA,I OP,X,DA,TO KEN,NEW K  ZTSTOP
  22383   "RTN","VPR HTTP",67,0 )
  22384    S IOP="NU LL" D ^%ZI S
  22385   "RTN","VPR HTTP",68,0 )
  22386    S ID=(+$H )+$P($H,", ",2)
  22387   "RTN","VPR HTTP",69,0 )
  22388    S DFN=0 F   S DFN=$O (^XTMP("VP R",DFN)) Q :DFN<1  I  $D(^(DFN)) >9 D
  22389   "RTN","VPR HTTP",70,0 )
  22390    . L +^XTM P("VPR",DF N):5 Q:'$T   ;try aga in next cy cle
  22391   "RTN","VPR HTTP",71,0 )
  22392    . K DATA  M DATA=^XT MP("VPR",D FN)
  22393   "RTN","VPR HTTP",72,0 )
  22394    . S X=$G( ^XTMP("VPR ",DFN)) K  ^(DFN) S ^ (DFN)=X ;c lear list,  keep subs cription
  22395   "RTN","VPR HTTP",73,0 )
  22396    . L -^XTM P("VPR",DF N)
  22397   "RTN","VPR HTTP",74,0 )
  22398    . ; add t o list for  URL
  22399   "RTN","VPR HTTP",75,0 )
  22400    . S DA=0  F  S DA=$O (^VPR(560, "ADFN",DFN ,DA)) Q:DA <1  D
  22401   "RTN","VPR HTTP",76,0 )
  22402    .. S TOKE N=DA_"~"_I D,NEW(TOKE N)=""
  22403   "RTN","VPR HTTP",77,0 )
  22404    .. M ^XTM P("VPRX",T OKEN,DFN)= DATA
  22405   "RTN","VPR HTTP",78,0 )
  22406    D SEND(.N EW)
  22407   "RTN","VPR HTTP",79,0 )
  22408    I $$S^%ZT LOAD S ZTS TOP=1,ZTRE Q="@" Q
  22409   "RTN","VPR HTTP",80,0 )
  22410    D HANG S  ZTREQ="" ; re-queue
  22411   "RTN","VPR HTTP",81,0 )
  22412    Q
  22413   "RTN","VPR HTTP",82,0 )
  22414    ;
  22415   "RTN","VPR HTTP",83,0 )
  22416   SEND(LIST)  ; send ea ch list ID  to its UR L
  22417   "RTN","VPR HTTP",84,0 )
  22418    N SYS,ID, DA,URL,X
  22419   "RTN","VPR HTTP",85,0 )
  22420    S SYS=$$S YS
  22421   "RTN","VPR HTTP",86,0 )
  22422    ; DIV=$P( $$SITE^VAS ITE,U,3) ; station#
  22423   "RTN","VPR HTTP",87,0 )
  22424    S ID="" F   S ID=$O( LIST(ID))  Q:ID=""  D
  22425   "RTN","VPR HTTP",88,0 )
  22426    . S DA=+I D,URL=$G(^ VPR(560,DA ,.1)) Q:UR L=""
  22427   "RTN","VPR HTTP",89,0 )
  22428    . S URL=U RL_"?vista Id="_SYS_" &id="_ID
  22429   "RTN","VPR HTTP",90,0 )
  22430    . S X=$$G ETURL^XTHC 10(URL,,"V PRX") ;I X >200 = ERR OR
  22431   "RTN","VPR HTTP",91,0 )
  22432    Q
  22433   "RTN","VPR HTTP",92,0 )
  22434    ;
  22435   "RTN","VPR HTTP",93,0 )
  22436   SYS() ; --  return ha shed syste m name
  22437   "RTN","VPR HTTP",94,0 )
  22438    Q $$BASE^ XLFUTL($$C RC16^XLFCR C($$KSP^XU PARAM("WHE RE")),10,1 6)
  22439   "RTN","VPR HTTP",95,0 )
  22440    ;
  22441   "RTN","VPR HTTP",96,0 )
  22442   HANG ; --  wait #seco nds
  22443   "RTN","VPR HTTP",97,0 )
  22444    N X S X=$ $GET^XPAR( "ALL","VPR  TASK WAIT  TIME") S: 'X X=99
  22445   "RTN","VPR HTTP",98,0 )
  22446    H X
  22447   "RTN","VPR HTTP",99,0 )
  22448    Q
  22449   "RTN","VPR HTTP",100, 0)
  22450    ;
  22451   "RTN","VPR HTTP",101, 0)
  22452   KILL ; --  kill/reset  ^VPR(560)  for testi ng
  22453   "RTN","VPR HTTP",102, 0)
  22454    K ^VPR(56 0)
  22455   "RTN","VPR HTTP",103, 0)
  22456    S ^VPR(56 0,0)="VPR  SUBSCRIPTI ON^560^^"
  22457   "RTN","VPR HTTP",104, 0)
  22458    Q
  22459   "RTN","VPR IDX")
  22460   0^1^B14476 451
  22461   "RTN","VPR IDX",1,0)
  22462   VPRIDX ;SL C/MKB -- C reate VPR  triggers
  22463   "RTN","VPR IDX",2,0)
  22464    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  22465   "RTN","VPR IDX",3,0)
  22466    Q
  22467   "RTN","VPR IDX",4,0)
  22468    ;
  22469   "RTN","VPR IDX",5,0)
  22470   EN ; -- cr eate index  triggers
  22471   "RTN","VPR IDX",6,0)
  22472    ; GMPL                ;Problems  -- GMPL*2 *36 provid es protoco l event
  22473   "RTN","VPR IDX",7,0)
  22474    D GMRV                ;Vitals
  22475   "RTN","VPR IDX",8,0)
  22476    ; MDC                 ;CLiO      -- MD*1*3 8 provides  protocol  event
  22477   "RTN","VPR IDX",9,0)
  22478    ; TIU                 ;TIU       -- TIU*1* 106 provid es index e vent
  22479   "RTN","VPR IDX",10,0)
  22480    ;
  22481   "RTN","VPR IDX",11,0)
  22482    D EN^XPAR ("PKG.VIRT UAL PATIEN T RECORD", "VPR TASK  WAIT TIME" ,1,99)
  22483   "RTN","VPR IDX",12,0)
  22484    S ^XTMP(" VPR",0)="3 991231^311 0101^VPR P atient Dat a Monitor"
  22485   "RTN","VPR IDX",13,0)
  22486    Q
  22487   "RTN","VPR IDX",14,0)
  22488    ;
  22489   "RTN","VPR IDX",15,0)
  22490   GMPL ; --  create AVP R index on  Problem f ile #90000 11
  22491   "RTN","VPR IDX",16,0)
  22492    Q:$O(^DD( "IX","BB", 9000011,"A VPR",0))   ;exists
  22493   "RTN","VPR IDX",17,0)
  22494    N VPRX,VP RY
  22495   "RTN","VPR IDX",18,0)
  22496    S VPRX("F ILE")=9000 011,VPRX(" NAME")="AV PR"
  22497   "RTN","VPR IDX",19,0)
  22498    S VPRX("T YPE")="MU" ,VPRX("USE ")="A"
  22499   "RTN","VPR IDX",20,0)
  22500    S VPRX("E XECUTION") ="R",VPRX( "ACTIVITY" )=""
  22501   "RTN","VPR IDX",21,0)
  22502    S VPRX("S HORT DESCR ")="Event  for VPR"
  22503   "RTN","VPR IDX",22,0)
  22504    S VPRX("D ESCR",1)=" This index  invokes a  VPR event  point whe n problems  are modif ied."
  22505   "RTN","VPR IDX",23,0)
  22506    S VPRX("D ESCR",2)=" No actual  cross-refe rence node s are set  or killed. "
  22507   "RTN","VPR IDX",24,0)
  22508    S VPRX("S ET")="Q:$D (DIU(0))!( $G(XDRDVAL F)=1)  D G MPL^VPREVN T(X,DA)"
  22509   "RTN","VPR IDX",25,0)
  22510    S VPRX("K ILL")="Q", VPRX("WHOL E KILL")=" Q"
  22511   "RTN","VPR IDX",26,0)
  22512    S VPRX("V AL",1)=.02              ;Patient
  22513   "RTN","VPR IDX",27,0)
  22514    S VPRX("V AL",2)=.03              ;Date La st Modifie d
  22515   "RTN","VPR IDX",28,0)
  22516    D CREIXN^ DDMOD(.VPR X,"",.VPRY ) ;VPRY=ie n^name of  index
  22517   "RTN","VPR IDX",29,0)
  22518    Q
  22519   "RTN","VPR IDX",30,0)
  22520    ;
  22521   "RTN","VPR IDX",31,0)
  22522   GMRV ; --  create AVP R index on  GMRV Meas urement fi le #120.5
  22523   "RTN","VPR IDX",32,0)
  22524    Q:$O(^DD( "IX","BB", 120.5,"AVP R",0))  ;u pdate
  22525   "RTN","VPR IDX",33,0)
  22526    N VPRX,VP RY
  22527   "RTN","VPR IDX",34,0)
  22528    S VPRX("F ILE")=120. 5,VPRX("NA ME")="AVPR "
  22529   "RTN","VPR IDX",35,0)
  22530    S VPRX("T YPE")="MU" ,VPRX("USE ")="A"
  22531   "RTN","VPR IDX",36,0)
  22532    S VPRX("E XECUTION") ="R",VPRX( "ACTIVITY" )=""
  22533   "RTN","VPR IDX",37,0)
  22534    S VPRX("S HORT DESCR ")="Event  for VPR"
  22535   "RTN","VPR IDX",38,0)
  22536    S VPRX("D ESCR",1)=" This index  invokes a  VPR event  point whe n vitals a re modifie d."
  22537   "RTN","VPR IDX",39,0)
  22538    S VPRX("D ESCR",2)=" No actual  cross-refe rence node s are set  or killed. "
  22539   "RTN","VPR IDX",40,0)
  22540    S VPRX("S ET")="Q:$D (DIU(0))!( $G(XDRDVAL F)=1)  D G MRV^VPREVN T(X,DA,$G( X(3)))"
  22541   "RTN","VPR IDX",41,0)
  22542    S VPRX("K ILL")="Q", VPRX("WHOL E KILL")=" Q"
  22543   "RTN","VPR IDX",42,0)
  22544    S VPRX("V AL",1)=.02              ;Patient
  22545   "RTN","VPR IDX",43,0)
  22546    S VPRX("V AL",2)=1.2              ;Rate
  22547   "RTN","VPR IDX",44,0)
  22548    S VPRX("V AL",3)=2                ;Entered  in Error
  22549   "RTN","VPR IDX",45,0)
  22550    D CREIXN^ DDMOD(.VPR X,"",.VPRY ) ;VPRY=ie n^name of  index
  22551   "RTN","VPR IDX",46,0)
  22552    Q
  22553   "RTN","VPR IDX",47,0)
  22554    ;
  22555   "RTN","VPR IDX",48,0)
  22556   MDC ; -- c reate ASTA TUS index  on OBS fil e #704.117
  22557   "RTN","VPR IDX",49,0)
  22558    Q:$O(^DD( "IX","BB", 704.117,"A STATUS",0) )  ;exists
  22559   "RTN","VPR IDX",50,0)
  22560    N VPRX,VP RY
  22561   "RTN","VPR IDX",51,0)
  22562    S VPRX("F ILE")=704. 117,VPRX(" NAME")="AS TATUS"
  22563   "RTN","VPR IDX",52,0)
  22564    S VPRX("T YPE")="MU" ,VPRX("USE ")="A"
  22565   "RTN","VPR IDX",53,0)
  22566    S VPRX("E XECUTION") ="F",VPRX( "ACTIVITY" )=""
  22567   "RTN","VPR IDX",54,0)
  22568    S VPRX("S HORT DESCR ")="Used t o trigger  MD OBSERVA TION UPDAT E protocol "
  22569   "RTN","VPR IDX",55,0)
  22570    S VPRX("D ESCR",1)=" This index  invokes t he MD OBSE RVATION UP DATE proto col when t he"
  22571   "RTN","VPR IDX",56,0)
  22572    S VPRX("D ESCR",2)=" status of  OBS data i s changed  to or from  verified. "
  22573   "RTN","VPR IDX",57,0)
  22574    S VPRX("D ESCR",3)=" No actual  cross-refe rence node s are set  or killed. "
  22575   "RTN","VPR IDX",58,0)
  22576    S VPRX("S ET")="D:(( X1=""1"")! (X2=""1"") ) PROT^MDC PROTD Q"
  22577   "RTN","VPR IDX",59,0)
  22578    S VPRX("K ILL")="Q", VPRX("WHOL E KILL")=" Q"
  22579   "RTN","VPR IDX",60,0)
  22580    S VPRX("V AL",1)=.09              ;Status
  22581   "RTN","VPR IDX",61,0)
  22582    D CREIXN^ DDMOD(.VPR X,"",.VPRY ) ;VPRY=ie n^name of  index
  22583   "RTN","VPR IDX",62,0)
  22584    Q
  22585   "RTN","VPR IDX",63,0)
  22586    ;
  22587   "RTN","VPR IDX",64,0)
  22588   TIU ; -- c reate AVPR  index on  TIU Docume nt file #8 925
  22589   "RTN","VPR IDX",65,0)
  22590    Q:$O(^DD( "IX","BB", 8925,"AVPR ",0))  ;ex ists
  22591   "RTN","VPR IDX",66,0)
  22592    N VPRX,VP RY
  22593   "RTN","VPR IDX",67,0)
  22594    S VPRX("F ILE")=8925 ,VPRX("NAM E")="AVPR"
  22595   "RTN","VPR IDX",68,0)
  22596    S VPRX("T YPE")="MU" ,VPRX("USE ")="A"
  22597   "RTN","VPR IDX",69,0)
  22598    S VPRX("E XECUTION") ="R",VPRX( "ACTIVITY" )=""
  22599   "RTN","VPR IDX",70,0)
  22600    S VPRX("S HORT DESCR ")="Event  for VPR"
  22601   "RTN","VPR IDX",71,0)
  22602    S VPRX("D ESCR",1)=" This index  invokes a  VPR event  point whe n document s are modi fied."
  22603   "RTN","VPR IDX",72,0)
  22604    S VPRX("D ESCR",2)=" No actual  cross-refe rence node s are set  or killed. "
  22605   "RTN","VPR IDX",73,0)
  22606    S VPRX("S ET")="Q:$D (DIU(0))!( $G(XDRDVAL F)=1)  D:X (2)>5 TIU^ VPREVNT(X, DA)"
  22607   "RTN","VPR IDX",74,0)
  22608    S VPRX("K ILL")="Q", VPRX("WHOL E KILL")=" Q"
  22609   "RTN","VPR IDX",75,0)
  22610    S VPRX("V AL",1)=.02              ;Patient
  22611   "RTN","VPR IDX",76,0)
  22612    S VPRX("V AL",2)=.05              ;Status
  22613   "RTN","VPR IDX",77,0)
  22614    D CREIXN^ DDMOD(.VPR X,"",.VPRY ) ;VPRY=ie n^name of  index
  22615   "RTN","VPR IDX",78,0)
  22616    Q
  22617   "RTN","VPR JSON")
  22618   0^94^B1123 5996
  22619   "RTN","VPR JSON",1,0)
  22620   VPRJSON ;S LC/KCM --  Decode/Enc ode JSON
  22621   "RTN","VPR JSON",2,0)
  22622    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  22623   "RTN","VPR JSON",3,0)
  22624    ;
  22625   "RTN","VPR JSON",4,0)
  22626    ; Note:   Since the  routines u se closed  array refe rences, VV ROOT and V VERR
  22627   "RTN","VPR JSON",5,0)
  22628    ;         are used t o reduce r isk of nam ing confli cts on the  closed ar ray.
  22629   "RTN","VPR JSON",6,0)
  22630    ;
  22631   "RTN","VPR JSON",7,0)
  22632   DECODE(VVJ SON,VVROOT ,VVERR)  ;  Set JSON  object int o closed a rray ref V VROOT
  22633   "RTN","VPR JSON",8,0)
  22634    ; Example s: D DECOD E^VPRJSON( "MYJSON"," LOCALVAR", "LOCALERR" )
  22635   "RTN","VPR JSON",9,0)
  22636    ;            D DECOD E^VPRJSON( "^MYJSON(1 )","^GLO(9 9)","^TMP( $J)")
  22637   "RTN","VPR JSON",10,0 )
  22638    ;
  22639   "RTN","VPR JSON",11,0 )
  22640    ; VVJSON:  string/ar ray contai ning seria lized JSON  object
  22641   "RTN","VPR JSON",12,0 )
  22642    ; VVROOT:  closed ar ray refere nce for M  representa tion of ob ject
  22643   "RTN","VPR JSON",13,0 )
  22644    ;  VVERR:  contains  error mess ages, defa ults to ^T MP("VPRJER R",$J)
  22645   "RTN","VPR JSON",14,0 )
  22646    ;
  22647   "RTN","VPR JSON",15,0 )
  22648    ;   VVIDX : points t o next cha racter in  JSON strin g to proce ss
  22649   "RTN","VPR JSON",16,0 )
  22650    ; VVSTACK : manages  stack of s ubscripts
  22651   "RTN","VPR JSON",17,0 )
  22652    ;  VVPROP : true if  next strin g is prope rty name,  otherwise  treat as v alue
  22653   "RTN","VPR JSON",18,0 )
  22654    ;
  22655   "RTN","VPR JSON",19,0 )
  22656    G DIRECT^ VPRJSOND
  22657   "RTN","VPR JSON",20,0 )
  22658    ;
  22659   "RTN","VPR JSON",21,0 )
  22660   ENCODE(VVR OOT,VVJSON ,VVERR) ;  VVROOT (M  structure)  --> VVJSO N (array o f strings)
  22661   "RTN","VPR JSON",22,0 )
  22662    ; Example s:  D ENCO DE^VPRJSON ("^GLO(99, 2)","^TMP( $J)")
  22663   "RTN","VPR JSON",23,0 )
  22664    ;             D ENCO DE^VPRJSON ("LOCALVAR ","MYJSON" ,"LOCALERR ")
  22665   "RTN","VPR JSON",24,0 )
  22666    ;
  22667   "RTN","VPR JSON",25,0 )
  22668    ; VVROOT:  closed ar ray refere nce for M  representa tion of ob ject
  22669   "RTN","VPR JSON",26,0 )
  22670    ; VVJSON:  destinati on variabl e for the  string arr ay formatt ed as JSON
  22671   "RTN","VPR JSON",27,0 )
  22672    ;  VVERR:  contains  error mess ages, defa ults to ^T MP("VPRJER R",$J)
  22673   "RTN","VPR JSON",28,0 )
  22674    ;
  22675   "RTN","VPR JSON",29,0 )
  22676    G DIRECT^ VPRJSONE
  22677   "RTN","VPR JSON",30,0 )
  22678    ;
  22679   "RTN","VPR JSON",31,0 )
  22680    ;
  22681   "RTN","VPR JSON",32,0 )
  22682   ESC(X) ; E scape stri ng for JSO N
  22683   "RTN","VPR JSON",33,0 )
  22684    Q $$ESC^V PRJSONE(X)
  22685   "RTN","VPR JSON",34,0 )
  22686    ;
  22687   "RTN","VPR JSON",35,0 )
  22688   UES(X) ; U nescape JS ON string
  22689   "RTN","VPR JSON",36,0 )
  22690    Q $$UES^V PRJSOND(X)
  22691   "RTN","VPR JSON",37,0 )
  22692    ;
  22693   "RTN","VPR JSON",38,0 )
  22694   ERRX(ID,VA L) ; Set t he appropr iate error  message
  22695   "RTN","VPR JSON",39,0 )
  22696    ; switch  (ID) -- XE RRX ends s tatement
  22697   "RTN","VPR JSON",40,0 )
  22698    N ERRMSG
  22699   "RTN","VPR JSON",41,0 )
  22700    ;
  22701   "RTN","VPR JSON",42,0 )
  22702    ; Decode  Error Mess ages
  22703   "RTN","VPR JSON",43,0 )
  22704    ;
  22705   "RTN","VPR JSON",44,0 )
  22706    I ID="STL {" S ERRMS G="Stack t oo large f or new obj ect." G XE RRX
  22707   "RTN","VPR JSON",45,0 )
  22708    I ID="SUF }" S ERRMS G="Stack U nderflow -  extra } f ound" G XE RRX
  22709   "RTN","VPR JSON",46,0 )
  22710    I ID="STL [" S ERRMS G="Stack t oo large f or new arr ay." G XER RX
  22711   "RTN","VPR JSON",47,0 )
  22712    I ID="SUF ]" S ERRMS G="Stack U nderflow -  extra ] f ound." G X ERRX
  22713   "RTN","VPR JSON",48,0 )
  22714    I ID="OBM " S ERRMSG ="Array mi smatch - e xpected ]  got }." G  XERRX
  22715   "RTN","VPR JSON",49,0 )
  22716    I ID="ARM " S ERRMSG ="Object m ismatch -  expected }  got ]." G  XERRX
  22717   "RTN","VPR JSON",50,0 )
  22718    I ID="MPN " S ERRMSG ="Missing  property n ame." G XE RRX
  22719   "RTN","VPR JSON",51,0 )
  22720    I ID="EXT " S ERRMSG ="Expected  true, got  "_VAL G X ERRX
  22721   "RTN","VPR JSON",52,0 )
  22722    I ID="EXF " S ERRMSG ="Expected  false, go t "_VAL G  XERRX
  22723   "RTN","VPR JSON",53,0 )
  22724    I ID="EXN " S ERRMSG ="Expected  null, got  "_VAL G X ERRX
  22725   "RTN","VPR JSON",54,0 )
  22726    I ID="TKN " S ERRMSG ="Unable t o identify  type of t oken, valu e was "_VA L G XERRX
  22727   "RTN","VPR JSON",55,0 )
  22728    I ID="SCT " S ERRMSG ="Stack mi smatch - e xit stack  level was   "_VAL G X ERRX
  22729   "RTN","VPR JSON",56,0 )
  22730    I ID="EIQ " S ERRMSG ="Close qu ote not fo und before  end of in put." G XE RRX
  22731   "RTN","VPR JSON",57,0 )
  22732    I ID="EIU " S ERRMSG ="Unexpect ed end of  input whil e unescapi ng." G XER RX
  22733   "RTN","VPR JSON",58,0 )
  22734    I ID="RSB " S ERRMSG ="Reverse  search for  \ past be ginning of  input." G  XERRX
  22735   "RTN","VPR JSON",59,0 )
  22736    I ID="ORN " S ERRMSG ="Overrun  while scan ning name. " G XERRX
  22737   "RTN","VPR JSON",60,0 )
  22738    I ID="OR# " S ERRMSG ="Overrun  while scan ning numbe r." G XERR X
  22739   "RTN","VPR JSON",61,0 )
  22740    I ID="ORB " S ERRMSG ="Overrun  while scan ning boole an." G XER RX
  22741   "RTN","VPR JSON",62,0 )
  22742    I ID="ESC " S ERRMSG ="Escaped  character  not recogn ized"_VAL  G XERRX
  22743   "RTN","VPR JSON",63,0 )
  22744    ;
  22745   "RTN","VPR JSON",64,0 )
  22746    ; Encode  Error Mess ages
  22747   "RTN","VPR JSON",65,0 )
  22748    ;
  22749   "RTN","VPR JSON",66,0 )
  22750    I ID="SOB " S ERRMSG ="Unable t o serializ e node as  object, va lue was "_ VAL G XERR X
  22751   "RTN","VPR JSON",67,0 )
  22752    I ID="SAR " S ERRMSG ="Unable t o serializ e node as  array, val ue was "_V AL G XERRX
  22753   "RTN","VPR JSON",68,0 )
  22754    S ERRMSG= "Unspecifi ed error " _ID_" "_$G (VAL)
  22755   "RTN","VPR JSON",69,0 )
  22756   XERRX ; en d switch
  22757   "RTN","VPR JSON",70,0 )
  22758    S @VVERR@ (0)=$G(@VV ERR@(0))+1
  22759   "RTN","VPR JSON",71,0 )
  22760    S @VVERR@ (@VVERR@(0 ))=ERRMSG
  22761   "RTN","VPR JSON",72,0 )
  22762    S VVERROR S=VVERRORS +1
  22763   "RTN","VPR JSON",73,0 )
  22764    Q
  22765   "RTN","VPR JSOND")
  22766   0^95^B7023 2279
  22767   "RTN","VPR JSOND",1,0 )
  22768   VPRJSOND ; SLC/KCM --  Decode JS ON
  22769   "RTN","VPR JSOND",2,0 )
  22770    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  22771   "RTN","VPR JSOND",3,0 )
  22772    ;
  22773   "RTN","VPR JSOND",4,0 )
  22774   DECODE(VVJ SON,VVROOT ,VVERR) ;  Set JSON o bject into  closed ar ray ref VV ROOT
  22775   "RTN","VPR JSOND",5,0 )
  22776    ;
  22777   "RTN","VPR JSOND",6,0 )
  22778   DIRECT ; T AG for use  by DECODE ^VPRJSON
  22779   "RTN","VPR JSOND",7,0 )
  22780    ;
  22781   "RTN","VPR JSOND",8,0 )
  22782    ; Example s: D DECOD E^VPRJSON( "MYJSON"," LOCALVAR", "LOCALERR" )
  22783   "RTN","VPR JSOND",9,0 )
  22784    ;            D DECOD E^VPRJSON( "^MYJSON(1 )","^GLO(9 9)","^TMP( $J)")
  22785   "RTN","VPR JSOND",10, 0)
  22786    ;
  22787   "RTN","VPR JSOND",11, 0)
  22788    ; VVJSON:  string/ar ray contai ning seria lized JSON  object
  22789   "RTN","VPR JSOND",12, 0)
  22790    ; VVROOT:  closed ar ray refere nce for M  representa tion of ob ject
  22791   "RTN","VPR JSOND",13, 0)
  22792    ;  VVERR:  contains  error mess ages, defa ults to ^T MP("VPRJER R",$J)
  22793   "RTN","VPR JSOND",14, 0)
  22794    ;
  22795   "RTN","VPR JSOND",15, 0)
  22796    ;   VVIDX : points t o next cha racter in  JSON strin g to proce ss
  22797   "RTN","VPR JSOND",16, 0)
  22798    ; VVSTACK : manages  stack of s ubscripts
  22799   "RTN","VPR JSOND",17, 0)
  22800    ;  VVPROP : true if  next strin g is prope rty name,  otherwise  treat as v alue
  22801   "RTN","VPR JSOND",18, 0)
  22802    ;
  22803   "RTN","VPR JSOND",19, 0)
  22804    N VVMAX S  VVMAX=400 0 ; limit  document l ines to 40 00 charact ers
  22805   "RTN","VPR JSOND",20, 0)
  22806    S VVERR=$ G(VVERR,"^ TMP(""VPRJ ERR"",$J)" )
  22807   "RTN","VPR JSOND",21, 0)
  22808    ; If a si mple strin g is passe d in, move  it to an  temp array  (VVINPUT)
  22809   "RTN","VPR JSOND",22, 0)
  22810    ; so that  the proce ssing is c onsistentl y on an ar ray.
  22811   "RTN","VPR JSOND",23, 0)
  22812    I $D(@VVJ SON)=1 N V VINPUT S V VINPUT(1)= @VVJSON,VV JSON="VVIN PUT"
  22813   "RTN","VPR JSOND",24, 0)
  22814    S VVROOT= $NA(@VVROO T@("Z")),V VROOT=$E(V VROOT,1,$L (VVROOT)-4 ) ; make o pen array  ref
  22815   "RTN","VPR JSOND",25, 0)
  22816    N VVLINE, VVIDX,VVST ACK,VVPROP ,VVTYPE,VV ERRORS
  22817   "RTN","VPR JSOND",26, 0)
  22818    S VVLINE= $O(@VVJSON @("")),VVI DX=1,VVSTA CK=0,VVPRO P=0,VVERRO RS=0
  22819   "RTN","VPR JSOND",27, 0)
  22820    F  S VVTY PE=$$NXTKN () Q:VVTYP E=""  D  I  VVERRORS  Q
  22821   "RTN","VPR JSOND",28, 0)
  22822    . I VVTYP E="{" S VV STACK=VVST ACK+1,VVST ACK(VVSTAC K)="",VVPR OP=1 D:VVS TACK>64 ER RX("STL{")  Q
  22823   "RTN","VPR JSOND",29, 0)
  22824    . I VVTYP E="}" D  Q UIT
  22825   "RTN","VPR JSOND",30, 0)
  22826    . . I +VV STACK(VVST ACK)=VVSTA CK(VVSTACK ),VVSTACK( VVSTACK) D  ERRX("OBM ") ; Numer ic and tru e only
  22827   "RTN","VPR JSOND",31, 0)
  22828    . . S VVS TACK=VVSTA CK-1 D:VVS TACK<0 ERR X("SUF}")
  22829   "RTN","VPR JSOND",32, 0)
  22830    . I VVTYP E="[" S VV STACK=VVST ACK+1,VVST ACK(VVSTAC K)=1 D:VVS TACK>64 ER RX("STL[")  Q
  22831   "RTN","VPR JSOND",33, 0)
  22832    . I VVTYP E="]" D:'V VSTACK(VVS TACK) ERRX ("ARM") S  VVSTACK=VV STACK-1 D: VVSTACK<0  ERRX("SUF] ") Q
  22833   "RTN","VPR JSOND",34, 0)
  22834    . I VVTYP E="," D  Q
  22835   "RTN","VPR JSOND",35, 0)
  22836    . . I +VV STACK(VVST ACK)=VVSTA CK(VVSTACK ),VVSTACK( VVSTACK) S  VVSTACK(V VSTACK)=VV STACK(VVST ACK)+1  ;  VEN/SMH -  next in ar ray 
  22837   "RTN","VPR JSOND",36, 0)
  22838    . . E  S  VVPROP=1                                       ; or ne xt propert y name
  22839   "RTN","VPR JSOND",37, 0)
  22840    . I VVTYP E=":" S VV PROP=0 D:' $L($G(VVST ACK(VVSTAC K))) ERRX( "MPN") Q
  22841   "RTN","VPR JSOND",38, 0)
  22842    . I VVTYP E="""" D   Q
  22843   "RTN","VPR JSOND",39, 0)
  22844    . . I VVP ROP S VVST ACK(VVSTAC K)=$$NAMPA RS() I 1
  22845   "RTN","VPR JSOND",40, 0)
  22846    . . E  D  ADDSTR
  22847   "RTN","VPR JSOND",41, 0)
  22848    . S VVTYP E=$TR(VVTY PE,"TFN"," tfn")
  22849   "RTN","VPR JSOND",42, 0)
  22850    . I VVTYP E="t" D SE TBOOL("t")  Q
  22851   "RTN","VPR JSOND",43, 0)
  22852    . I VVTYP E="f" D SE TBOOL("f")  Q
  22853   "RTN","VPR JSOND",44, 0)
  22854    . I VVTYP E="n" D SE TBOOL("n")  Q
  22855   "RTN","VPR JSOND",45, 0)
  22856    . I "0123 456789+-.e E"[VVTYPE  D SETNUM(V VTYPE) Q   ;S @$$CURN ODE()=$$NU MPARS(VVTY PE) Q
  22857   "RTN","VPR JSOND",46, 0)
  22858    . D ERRX( "TKN",VVTY PE)
  22859   "RTN","VPR JSOND",47, 0)
  22860    I VVSTACK '=0 D ERRX ("SCT",VVS TACK)
  22861   "RTN","VPR JSOND",48, 0)
  22862    Q
  22863   "RTN","VPR JSOND",49, 0)
  22864   NXTKN() ;  Move the p ointers to  the begin ning of th e next tok en
  22865   "RTN","VPR JSOND",50, 0)
  22866    N VVDONE, VVEOF,VVTO KEN
  22867   "RTN","VPR JSOND",51, 0)
  22868    S VVDONE= 0,VVEOF=0  F  D  Q:VV DONE!VVEOF   ; eat sp aces & new  lines unt il next vi sible char
  22869   "RTN","VPR JSOND",52, 0)
  22870    . I VVIDX >$L(@VVJSO N@(VVLINE) ) S VVLINE =$O(@VVJSO N@(VVLINE) ),VVIDX=1  I 'VVLINE  S VVEOF=1  Q
  22871   "RTN","VPR JSOND",53, 0)
  22872    . I $A(@V VJSON@(VVL INE),VVIDX )>32 S VVD ONE=1 Q
  22873   "RTN","VPR JSOND",54, 0)
  22874    . S VVIDX =VVIDX+1
  22875   "RTN","VPR JSOND",55, 0)
  22876    Q:VVEOF " "  ; we're  at the en d of input
  22877   "RTN","VPR JSOND",56, 0)
  22878    S VVTOKEN =$E(@VVJSO N@(VVLINE) ,VVIDX),VV IDX=VVIDX+ 1
  22879   "RTN","VPR JSOND",57, 0)
  22880    Q VVTOKEN
  22881   "RTN","VPR JSOND",58, 0)
  22882    ;
  22883   "RTN","VPR JSOND",59, 0)
  22884   ADDSTR ; A dd string  value to c urrent nod e, escapin g text alo ng the way
  22885   "RTN","VPR JSOND",60, 0)
  22886    ; Expects  VVLINE,VV IDX to ref erence tha t starting  point of  the index
  22887   "RTN","VPR JSOND",61, 0)
  22888    ; TODO: a dd a mecha nism to sp ecify name s that sho uld not be  escaped
  22889   "RTN","VPR JSOND",62, 0)
  22890    ;       j ust store  as ":")= a nd ":",n)=
  22891   "RTN","VPR JSOND",63, 0)
  22892    ;
  22893   "RTN","VPR JSOND",64, 0)
  22894    ; Happy p ath -- we  find the e nd quote i n the same  line
  22895   "RTN","VPR JSOND",65, 0)
  22896    N VVEND,V VX
  22897   "RTN","VPR JSOND",66, 0)
  22898    S VVEND=$ F(@VVJSON@ (VVLINE)," """,VVIDX)
  22899   "RTN","VPR JSOND",67, 0)
  22900    I VVEND,( $E(@VVJSON @(VVLINE), VVEND-2)'= "\") D SET STR  QUIT   ;normal
  22901   "RTN","VPR JSOND",68, 0)
  22902    I VVEND,$ $ISCLOSEQ( VVLINE) D  SETSTR QUI T  ;close  quote prec eded by es caped \
  22903   "RTN","VPR JSOND",69, 0)
  22904    ;
  22905   "RTN","VPR JSOND",70, 0)
  22906    ; Less ha ppy path - - first qu ote wasn't  close quo te
  22907   "RTN","VPR JSOND",71, 0)
  22908    N VVDONE, VVTLINE
  22909   "RTN","VPR JSOND",72, 0)
  22910    S VVDONE= 0,VVTLINE= VVLINE ; V VTLINE for  temporary  increment  of VVLINE
  22911   "RTN","VPR JSOND",73, 0)
  22912    F  D  Q:V VDONE  Q:V VERRORS
  22913   "RTN","VPR JSOND",74, 0)
  22914    . ;if no  quote on c urrent lin e advance  line, scan  again
  22915   "RTN","VPR JSOND",75, 0)
  22916    . I 'VVEN D S VVTLIN E=VVTLINE+ 1,VVEND=1  I '$D(@VVJ SON@(VVTLI NE)) D ERR X("EIQ") Q
  22917   "RTN","VPR JSOND",76, 0)
  22918    . S VVEND =$F(@VVJSO N@(VVTLINE ),"""",VVE ND)
  22919   "RTN","VPR JSOND",77, 0)
  22920    . Q:'VVEN D  ; conti nue on to  next line  if no quot e found on  this one
  22921   "RTN","VPR JSOND",78, 0)
  22922    . I (VVEN D>2),($E(@ VVJSON@(VV TLINE),VVE ND-2)'="\" ) S VVDONE =1 Q  ; fo und quote  position
  22923   "RTN","VPR JSOND",79, 0)
  22924    . S VVDON E=$$ISCLOS EQ(VVTLINE ) ; see if  this is a n escaped  quote or c losing quo te
  22925   "RTN","VPR JSOND",80, 0)
  22926    Q:VVERROR S
  22927   "RTN","VPR JSOND",81, 0)
  22928    ; unescap e from VVI DX to VVEN D, using \ -extension  nodes as  necessary
  22929   "RTN","VPR JSOND",82, 0)
  22930    D UESEXT
  22931   "RTN","VPR JSOND",83, 0)
  22932    ; now we  need to mo ve VVLINE  and VVIDX  to next pa rsing poin t
  22933   "RTN","VPR JSOND",84, 0)
  22934    S VVLINE= VVTLINE,VV IDX=VVEND
  22935   "RTN","VPR JSOND",85, 0)
  22936    Q
  22937   "RTN","VPR JSOND",86, 0)
  22938   SETSTR ; S et simple  string val ue from wi thin same  line
  22939   "RTN","VPR JSOND",87, 0)
  22940    ; expects  VVJSON, V VLINE, VVI NX, VVEND
  22941   "RTN","VPR JSOND",88, 0)
  22942    N VVX
  22943   "RTN","VPR JSOND",89, 0)
  22944    S VVX=$E( @VVJSON@(V VLINE),VVI DX,VVEND-2 ),VVIDX=VV END
  22945   "RTN","VPR JSOND",90, 0)
  22946    S @$$CURN ODE()=$$UE S(VVX)
  22947   "RTN","VPR JSOND",91, 0)
  22948    ; "\s" no de indicat es value i s really a  string in  case valu
  22949   "RTN","VPR JSOND",92, 0)
  22950    ;      co llates as  numeric or  equals bo olean keyw ords
  22951   "RTN","VPR JSOND",93, 0)
  22952    I VVX']]$ C(1) S @$$ CURNODE()@ ("\s")=""
  22953   "RTN","VPR JSOND",94, 0)
  22954    I VVX="tr ue"!(VVX=" false")!(V VX="null")  S @$$CURN ODE()@("\s ")=""
  22955   "RTN","VPR JSOND",95, 0)
  22956    I VVIDX>$ L(@VVJSON@ (VVLINE))  S VVLINE=V VLINE+1,VV IDX=1
  22957   "RTN","VPR JSOND",96, 0)
  22958    Q
  22959   "RTN","VPR JSOND",97, 0)
  22960   UESEXT ; u nescape fr om VVLINE, VVIDX to V VTLINE,VVE ND & exten d (\) if n ecessary
  22961   "RTN","VPR JSOND",98, 0)
  22962    ; expects  VVLINE,VV IDX,VVTLIN E,VVEND
  22963   "RTN","VPR JSOND",99, 0)
  22964    N VVI,VVY ,VVSTART,V VSTOP,VVDO NE,VVBUF,V VNODE,VVMO RE,VVTO
  22965   "RTN","VPR JSOND",100 ,0)
  22966    S VVNODE= $$CURNODE( ),VVBUF="" ,VVMORE=0, VVSTOP=VVE ND-2
  22967   "RTN","VPR JSOND",101 ,0)
  22968    S VVI=VVI DX,VVY=VVL INE,VVDONE =0
  22969   "RTN","VPR JSOND",102 ,0)
  22970    F  D  Q:V VDONE  Q:V VERRORS
  22971   "RTN","VPR JSOND",103 ,0)
  22972    . S VVSTA RT=VVI,VVI =$F(@VVJSO N@(VVY),"\ ",VVI)
  22973   "RTN","VPR JSOND",104 ,0)
  22974    . ; if we  are on th e last lin e, don't e xtract pas t VVSTOP
  22975   "RTN","VPR JSOND",105 ,0)
  22976    . I (VVY= VVTLINE) S  VVTO=$S(' VVI:VVSTOP ,VVI>VVSTO P:VVSTOP,1 :VVI-2) I  1
  22977   "RTN","VPR JSOND",106 ,0)
  22978    . E  S VV TO=$S('VVI :99999,1:V VI-2)
  22979   "RTN","VPR JSOND",107 ,0)
  22980    . D ADDBU F($E(@VVJS ON@(VVY),V VSTART,VVT O))
  22981   "RTN","VPR JSOND",108 ,0)
  22982    . I (VVY' <VVTLINE), (('VVI)!(V VI>VVSTOP) ) S VVDONE =1 QUIT  ;  now past  close quot e
  22983   "RTN","VPR JSOND",109 ,0)
  22984    . I 'VVI  S VVY=VVY+ 1,VVI=1 QU IT  ; noth ing escape d, go to n ext line
  22985   "RTN","VPR JSOND",110 ,0)
  22986    . I VVI>$ L(@VVJSON@ (VVY)) S V VY=VVY+1,V VI=1 I '$D (@VVJSON@( VVY)) D ER RX("EIU")
  22987   "RTN","VPR JSOND",111 ,0)
  22988    . N VVTGT  S VVTGT=$ E(@VVJSON@ (VVY),VVI)
  22989   "RTN","VPR JSOND",112 ,0)
  22990    . I VVTGT ="u" D  I  1
  22991   "RTN","VPR JSOND",113 ,0)
  22992    . . N VVT GTC S VVTG TC=$E(@VVJ SON@(VVY), VVI+1,VVI+ 4),VVI=VVI +4
  22993   "RTN","VPR JSOND",114 ,0)
  22994    . . I $L( VVTGTC)<4  S VVY=VVY+ 1,VVI=4-$L (VVTGTC),V VTGTC=VVTG TC_$E(@VVJ SON@(VVY), 1,VVI)
  22995   "RTN","VPR JSOND",115 ,0)
  22996    . . D ADD BUF($C($$D EC^XLFUTL( VVTGTC,16) ))
  22997   "RTN","VPR JSOND",116 ,0)
  22998    . E  D AD DBUF($$REA LCHAR(VVTG T))
  22999   "RTN","VPR JSOND",117 ,0)
  23000    . S VVI=V VI+1
  23001   "RTN","VPR JSOND",118 ,0)
  23002    . I (VVY' <VVTLINE), (VVI>VVSTO P) S VVDON E=1 ; VVI  incremente d past sto p
  23003   "RTN","VPR JSOND",119 ,0)
  23004    Q:VVERROR S
  23005   "RTN","VPR JSOND",120 ,0)
  23006    D SAVEBUF
  23007   "RTN","VPR JSOND",121 ,0)
  23008    Q
  23009   "RTN","VPR JSOND",122 ,0)
  23010   ADDBUF(VVX ) ; add bu ffer of ch aracters t o destinat ion
  23011   "RTN","VPR JSOND",123 ,0)
  23012    ; expects  VVBUF,VVM AX,VVNODE, VVMORE to  be defined
  23013   "RTN","VPR JSOND",124 ,0)
  23014    ; used di rectly by  ADDSTR
  23015   "RTN","VPR JSOND",125 ,0)
  23016    I $L(VVX) +$L(VVBUF) >VVMAX D S AVEBUF
  23017   "RTN","VPR JSOND",126 ,0)
  23018    S VVBUF=V VBUF_VVX
  23019   "RTN","VPR JSOND",127 ,0)
  23020    Q
  23021   "RTN","VPR JSOND",128 ,0)
  23022   SAVEBUF ;  write out  buffer to  destinatio n
  23023   "RTN","VPR JSOND",129 ,0)
  23024    ; expects  VVBUF,VVM AX,VVNODE, VVMORE to  be defined
  23025   "RTN","VPR JSOND",130 ,0)
  23026    ; used di rectly by  ADDSTR,ADD BUF
  23027   "RTN","VPR JSOND",131 ,0)
  23028    I VVMORE  S @VVNODE@ ("\",VVMOR E)=VVBUF
  23029   "RTN","VPR JSOND",132 ,0)
  23030    I 'VVMORE  S @VVNODE =VVBUF I $ L(VVBUF)<1 9,+$E(VVBU F,1,18) S  @VVNODE@(" \s")=""
  23031   "RTN","VPR JSOND",133 ,0)
  23032    S VVMORE= VVMORE+1,V VBUF=""
  23033   "RTN","VPR JSOND",134 ,0)
  23034    Q
  23035   "RTN","VPR JSOND",135 ,0)
  23036   ISCLOSEQ(V VBLINE) ;  return tru e if this  is a closi ng, rather  than esca ped, quote
  23037   "RTN","VPR JSOND",136 ,0)
  23038    ; expects
  23039   "RTN","VPR JSOND",137 ,0)
  23040    ;   VVJSO N: lines o f the JSON  encoded s tring
  23041   "RTN","VPR JSOND",138 ,0)
  23042    ;    VVID X: points  to 1st cha racter of  the segmen t
  23043   "RTN","VPR JSOND",139 ,0)
  23044    ;   VVLIN E: points  to the lin e in which  the segme nt starts
  23045   "RTN","VPR JSOND",140 ,0)
  23046    ;    VVEN D: points  to 1st cha racter aft er the " ( may be pas t the end  of the lin e)
  23047   "RTN","VPR JSOND",141 ,0)
  23048    ; used di rectly by  ADDSTR
  23049   "RTN","VPR JSOND",142 ,0)
  23050    N VVBS,VV BIDX,VVBDO NE
  23051   "RTN","VPR JSOND",143 ,0)
  23052    S VVBS=0, VVBIDX=VVE ND-2,VVBDO NE=0 ; VVB IDX starts  at 1st ch aracter be fore quote
  23053   "RTN","VPR JSOND",144 ,0)
  23054    ; count t he backsla shes prece ding the q uote (odd  number mea ns the quo te was esc aped)
  23055   "RTN","VPR JSOND",145 ,0)
  23056    F  D  Q:V VBDONE!VVE RRORS
  23057   "RTN","VPR JSOND",146 ,0)
  23058    . I VVBID X<1 D  Q   ; when VVB IDX<1 go b ack a line
  23059   "RTN","VPR JSOND",147 ,0)
  23060    . . S VVB LINE=VVBLI NE-1 I VVB LINE<VVLIN E D ERRX(" RSB") Q
  23061   "RTN","VPR JSOND",148 ,0)
  23062    . . S VVB IDX=$L(@VV JSON@(VVBL INE))
  23063   "RTN","VPR JSOND",149 ,0)
  23064    . I $E(@V VJSON@(VVB LINE),VVBI DX)'="\" S  VVBDONE=1  Q
  23065   "RTN","VPR JSOND",150 ,0)
  23066    . S VVBS= VVBS+1,VVB IDX=VVBIDX -1
  23067   "RTN","VPR JSOND",151 ,0)
  23068    Q VVBS#2= 0  ; VVBS  is even if  this is a  close quo te
  23069   "RTN","VPR JSOND",152 ,0)
  23070    ;
  23071   "RTN","VPR JSOND",153 ,0)
  23072   NAMPARS()  ; Return p arsed name , advancin g index pa st the clo se quote
  23073   "RTN","VPR JSOND",154 ,0)
  23074    ; -- This  assumes n o embedded  quotes ar e in the n ame itself  --
  23075   "RTN","VPR JSOND",155 ,0)
  23076    N VVEND,V VDONE,VVNA ME
  23077   "RTN","VPR JSOND",156 ,0)
  23078    S VVDONE= 0,VVNAME=" "
  23079   "RTN","VPR JSOND",157 ,0)
  23080    F  D  Q:V VDONE  Q:V VERRORS
  23081   "RTN","VPR JSOND",158 ,0)
  23082    . S VVEND =$F(@VVJSO N@(VVLINE) ,"""",VVID X)
  23083   "RTN","VPR JSOND",159 ,0)
  23084    . I VVEND  S VVNAME= VVNAME_$E( @VVJSON@(V VLINE),VVI DX,VVEND-2 ),VVIDX=VV END,VVDONE =1
  23085   "RTN","VPR JSOND",160 ,0)
  23086    . I 'VVEN D S VVNAME =VVNAME_$E (@VVJSON@( VVLINE),VV IDX,$L(@VV JSON@(VVLI NE)))
  23087   "RTN","VPR JSOND",161 ,0)
  23088    . I 'VVEN D!(VVEND>$ L(@VVJSON@ (VVLINE)))  S VVLINE= VVLINE+1,V VIDX=1 I ' $D(@VVJSON @(VVLINE))  D ERRX("O RN")
  23089   "RTN","VPR JSOND",162 ,0)
  23090    ; prepend  quote if  label coll ates as nu meric -- a ssumes no  quotes in  label
  23091   "RTN","VPR JSOND",163 ,0)
  23092    I VVNAME' ]]$C(1) S  VVNAME=""" """_VVNAME
  23093   "RTN","VPR JSOND",164 ,0)
  23094    Q VVNAME
  23095   "RTN","VPR JSOND",165 ,0)
  23096    ;
  23097   "RTN","VPR JSOND",166 ,0)
  23098   SETNUM(VVD IGIT) ; Se t numeric  along with  any neces sary modif ier
  23099   "RTN","VPR JSOND",167 ,0)
  23100    N VVX
  23101   "RTN","VPR JSOND",168 ,0)
  23102    S VVX=$$N UMPARS(VVD IGIT)
  23103   "RTN","VPR JSOND",169 ,0)
  23104    S @$$CURN ODE()=+VVX
  23105   "RTN","VPR JSOND",170 ,0)
  23106    ; if nume ric is exp onent, "0. nnn" or "- 0.nnn" sto re origina l string
  23107   "RTN","VPR JSOND",171 ,0)
  23108    I +VVX'=V VX S @$$CU RNODE()@(" \n")=VVX
  23109   "RTN","VPR JSOND",172 ,0)
  23110    Q
  23111   "RTN","VPR JSOND",173 ,0)
  23112   NUMPARS(VV DIGIT) ; R eturn pars ed number,  advancing  index pas t end of n umber
  23113   "RTN","VPR JSOND",174 ,0)
  23114    ; VVIDX i ntially re ferences t he second  digit
  23115   "RTN","VPR JSOND",175 ,0)
  23116    N VVDONE, VVNUM
  23117   "RTN","VPR JSOND",176 ,0)
  23118    S VVDONE= 0,VVNUM=VV DIGIT
  23119   "RTN","VPR JSOND",177 ,0)
  23120    F  D  Q:V VDONE  Q:V VERRORS
  23121   "RTN","VPR JSOND",178 ,0)
  23122    . I '("01 23456789+- .eE"[$E(@V VJSON@(VVL INE),VVIDX )) S VVDON E=1 Q
  23123   "RTN","VPR JSOND",179 ,0)
  23124    . S VVNUM =VVNUM_$E( @VVJSON@(V VLINE),VVI DX)
  23125   "RTN","VPR JSOND",180 ,0)
  23126    . S VVIDX =VVIDX+1 I  VVIDX>$L( @VVJSON@(V VLINE)) S  VVLINE=VVL INE+1,VVID X=1 I '$D( @VVJSON@(V VLINE)) D  ERRX("OR#" )
  23127   "RTN","VPR JSOND",181 ,0)
  23128    Q VVNUM
  23129   "RTN","VPR JSOND",182 ,0)
  23130    ;
  23131   "RTN","VPR JSOND",183 ,0)
  23132   SETBOOL(VV LTR) ; Par se and set  boolean v alue, adva ncing inde x past end  of value
  23133   "RTN","VPR JSOND",184 ,0)
  23134    N VVDONE, VVBOOL,VVX
  23135   "RTN","VPR JSOND",185 ,0)
  23136    S VVDONE= 0,VVBOOL=V VLTR
  23137   "RTN","VPR JSOND",186 ,0)
  23138    F  D  Q:V VDONE  Q:V VERRORS
  23139   "RTN","VPR JSOND",187 ,0)
  23140    . S VVX=$ TR($E(@VVJ SON@(VVLIN E),VVIDX), "TRUEFALSN ","truefal sn")
  23141   "RTN","VPR JSOND",188 ,0)
  23142    . I '("tr uefalsn"[V VX) S VVDO NE=1 Q
  23143   "RTN","VPR JSOND",189 ,0)
  23144    . S VVBOO L=VVBOOL_V VX
  23145   "RTN","VPR JSOND",190 ,0)
  23146    . S VVIDX =VVIDX+1 I  VVIDX>$L( @VVJSON@(V VLINE)) S  VVLINE=VVL INE+1,VVID X=1 I '$D( @VVJSON@(V VLINE)) D  ERRX("ORB" )
  23147   "RTN","VPR JSOND",191 ,0)
  23148    I VVLTR=" t",(VVBOOL '="true")  D ERRX("EX T",VVTYPE)
  23149   "RTN","VPR JSOND",192 ,0)
  23150    I VVLTR=" f",(VVBOOL '="false")  D ERRX("E XF",VVTYPE )
  23151   "RTN","VPR JSOND",193 ,0)
  23152    I VVLTR=" n",(VVBOOL '="null")  D ERRX("EX N",VVTYPE)
  23153   "RTN","VPR JSOND",194 ,0)
  23154    S @$$CURN ODE()=VVBO OL
  23155   "RTN","VPR JSOND",195 ,0)
  23156    Q
  23157   "RTN","VPR JSOND",196 ,0)
  23158    ;
  23159   "RTN","VPR JSOND",197 ,0)
  23160   OSETBOOL(V VX) ; set  a value an d incremen t VVIDX
  23161   "RTN","VPR JSOND",198 ,0)
  23162    S @$$CURN ODE()=VVX
  23163   "RTN","VPR JSOND",199 ,0)
  23164    S VVIDX=V VIDX+$L(VV X)-1
  23165   "RTN","VPR JSOND",200 ,0)
  23166    N VVDIFF  S VVDIFF=V VIDX-$L(@V VJSON@(VVL INE))  ; i n case VVI DX moves t o next lin e
  23167   "RTN","VPR JSOND",201 ,0)
  23168    I VVDIFF> 0 S VVLINE =VVLINE+1, VVIDX=VVDI FF I '$D(@ VVJSON@(VV LINE)) D E RRX("ORB")
  23169   "RTN","VPR JSOND",202 ,0)
  23170    Q
  23171   "RTN","VPR JSOND",203 ,0)
  23172   CURNODE()  ; Return a  global/lo cal variab le name ba sed on VVS TACK
  23173   "RTN","VPR JSOND",204 ,0)
  23174    ; Expects  VVSTACK t o be defin ed already
  23175   "RTN","VPR JSOND",205 ,0)
  23176    N VVI,VVS UBS
  23177   "RTN","VPR JSOND",206 ,0)
  23178    S VVSUBS= ""
  23179   "RTN","VPR JSOND",207 ,0)
  23180    F VVI=1:1 :VVSTACK S :VVI>1 VVS UBS=VVSUBS _"," D
  23181   "RTN","VPR JSOND",208 ,0)
  23182    . I VVSTA CK(VVI)=+V VSTACK(VVI ) S VVSUBS =VVSUBS_VV STACK(VVI)  ; VEN/SMH  Fix psudo  array bug .
  23183   "RTN","VPR JSOND",209 ,0)
  23184    . E  S VV SUBS=VVSUB S_""""_VVS TACK(VVI)_ """"
  23185   "RTN","VPR JSOND",210 ,0)
  23186    Q VVROOT_ VVSUBS_")"
  23187   "RTN","VPR JSOND",211 ,0)
  23188    ;
  23189   "RTN","VPR JSOND",212 ,0)
  23190   UES(X) ; U nescape JS ON string
  23191   "RTN","VPR JSOND",213 ,0)
  23192    ; copy se gments fro m START to  POS-2 (ri ght before  \)
  23193   "RTN","VPR JSOND",214 ,0)
  23194    ; transla te target  character  (which is  at $F posi tion)
  23195   "RTN","VPR JSOND",215 ,0)
  23196    N POS,Y,S TART
  23197   "RTN","VPR JSOND",216 ,0)
  23198    S POS=0,Y =""
  23199   "RTN","VPR JSOND",217 ,0)
  23200    F  S STAR T=POS+1 D   Q:START>$ L(X)
  23201   "RTN","VPR JSOND",218 ,0)
  23202    . S POS=$ F(X,"\",ST ART) ; fin d next pos ition
  23203   "RTN","VPR JSOND",219 ,0)
  23204    . I 'POS  S Y=Y_$E(X ,START,$L( X)),POS=$L (X) Q
  23205   "RTN","VPR JSOND",220 ,0)
  23206    . ; other wise handl e escaped  char
  23207   "RTN","VPR JSOND",221 ,0)
  23208    . N TGT
  23209   "RTN","VPR JSOND",222 ,0)
  23210    . S TGT=$ E(X,POS),Y =Y_$E(X,ST ART,POS-2)
  23211   "RTN","VPR JSOND",223 ,0)
  23212    . I TGT=" u" S Y=Y_$ C($$DEC^XL FUTL($E(X, POS+1,POS+ 4),16)),PO S=POS+4 Q
  23213   "RTN","VPR JSOND",224 ,0)
  23214    . S Y=Y_$ $REALCHAR( TGT)
  23215   "RTN","VPR JSOND",225 ,0)
  23216    Q Y
  23217   "RTN","VPR JSOND",226 ,0)
  23218    ;
  23219   "RTN","VPR JSOND",227 ,0)
  23220   REALCHAR(C ) ; Return  actual ch aracter fr om escaped
  23221   "RTN","VPR JSOND",228 ,0)
  23222    I C=""""  Q """"
  23223   "RTN","VPR JSOND",229 ,0)
  23224    I C="/" Q  "/"
  23225   "RTN","VPR JSOND",230 ,0)
  23226    I C="\" Q  "\"
  23227   "RTN","VPR JSOND",231 ,0)
  23228    I C="b" Q  $C(8)
  23229   "RTN","VPR JSOND",232 ,0)
  23230    I C="f" Q  $C(12)
  23231   "RTN","VPR JSOND",233 ,0)
  23232    I C="n" Q  $C(10)
  23233   "RTN","VPR JSOND",234 ,0)
  23234    I C="r" Q  $C(13)
  23235   "RTN","VPR JSOND",235 ,0)
  23236    I C="t" Q  $C(9)
  23237   "RTN","VPR JSOND",236 ,0)
  23238    I C="u" ; case cover ed above i n $$DEC^XL FUTL calls
  23239   "RTN","VPR JSOND",237 ,0)
  23240    ;otherwis e
  23241   "RTN","VPR JSOND",238 ,0)
  23242    I $L($G(V VERR)) D E RRX("ESC", C)
  23243   "RTN","VPR JSOND",239 ,0)
  23244    Q C
  23245   "RTN","VPR JSOND",240 ,0)
  23246    ;
  23247   "RTN","VPR JSOND",241 ,0)
  23248   ERRX(ID,VA L) ; Set t he appropr iate error  message
  23249   "RTN","VPR JSOND",242 ,0)
  23250    D ERRX^VP RJSON(ID,$ G(VAL))
  23251   "RTN","VPR JSOND",243 ,0)
  23252    Q
  23253   "RTN","VPR JSONE")
  23254   0^96^B2434 9845
  23255   "RTN","VPR JSONE",1,0 )
  23256   VPRJSONE ; SLC/KCM --  Encode JS ON
  23257   "RTN","VPR JSONE",2,0 )
  23258    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  23259   "RTN","VPR JSONE",3,0 )
  23260    ;
  23261   "RTN","VPR JSONE",4,0 )
  23262   ENCODE(VVR OOT,VVJSON ,VVERR) ;  VVROOT (M  structure)  --> VVJSO N (array o f strings)
  23263   "RTN","VPR JSONE",5,0 )
  23264    ;
  23265   "RTN","VPR JSONE",6,0 )
  23266   DIRECT ; T AG for use  by ENCODE ^VPRJSON
  23267   "RTN","VPR JSONE",7,0 )
  23268    ;
  23269   "RTN","VPR JSONE",8,0 )
  23270    ; Example s:  D ENCO DE^VPRJSON ("^GLO(99, 2)","^TMP( $J)")
  23271   "RTN","VPR JSONE",9,0 )
  23272    ;             D ENCO DE^VPRJSON ("LOCALVAR ","MYJSON" ,"LOCALERR ")
  23273   "RTN","VPR JSONE",10, 0)
  23274    ;
  23275   "RTN","VPR JSONE",11, 0)
  23276    ; VVROOT:  closed ar ray refere nce for M  representa tion of ob ject
  23277   "RTN","VPR JSONE",12, 0)
  23278    ; VVJSON:  destinati on variabl e for the  string arr ay formatt ed as JSON
  23279   "RTN","VPR JSONE",13, 0)
  23280    ;  VVERR:  contains  error mess ages, defa ults to ^T MP("VPRJER R",$J)
  23281   "RTN","VPR JSONE",14, 0)
  23282    ;
  23283   "RTN","VPR JSONE",15, 0)
  23284    S VVERR=$ G(VVERR,"^ TMP(""VPRJ ERR"",$J)" )
  23285   "RTN","VPR JSONE",16, 0)
  23286    I '$L($G( VVROOT)) ;  set error  info
  23287   "RTN","VPR JSONE",17, 0)
  23288    I '$L($G( VVJSON)) ;  set error  info
  23289   "RTN","VPR JSONE",18, 0)
  23290    N VVLINE, VVMAX,VVER RORS
  23291   "RTN","VPR JSONE",19, 0)
  23292    S VVLINE= 1,VVMAX=40 00,VVERROR S=0  ; 96  more bytes  of wiggle  room
  23293   "RTN","VPR JSONE",20, 0)
  23294    S @VVJSON @(VVLINE)= ""
  23295   "RTN","VPR JSONE",21, 0)
  23296    D SEROBJ( VVROOT)
  23297   "RTN","VPR JSONE",22, 0)
  23298    Q
  23299   "RTN","VPR JSONE",23, 0)
  23300    ;
  23301   "RTN","VPR JSONE",24, 0)
  23302   SEROBJ(VVR OOT) ; Ser ialize int o a JSON o bject
  23303   "RTN","VPR JSONE",25, 0)
  23304    N VVFIRST ,VVSUB,VVN XT
  23305   "RTN","VPR JSONE",26, 0)
  23306    S @VVJSON @(VVLINE)= @VVJSON@(V VLINE)_"{"
  23307   "RTN","VPR JSONE",27, 0)
  23308    S VVFIRST =1
  23309   "RTN","VPR JSONE",28, 0)
  23310    S VVSUB=" " F  S VVS UB=$O(@VVR OOT@(VVSUB )) Q:VVSUB =""  D
  23311   "RTN","VPR JSONE",29, 0)
  23312    . S:'VVFI RST @VVJSO N@(VVLINE) =@VVJSON@( VVLINE)_", " S VVFIRS T=0
  23313   "RTN","VPR JSONE",30, 0)
  23314    . ; get t he name pa rt
  23315   "RTN","VPR JSONE",31, 0)
  23316    . D SERNA ME(VVSUB)
  23317   "RTN","VPR JSONE",32, 0)
  23318    . ; if th is is a va lue, seria lize it
  23319   "RTN","VPR JSONE",33, 0)
  23320    . I $$ISV ALUE(VVROO T,VVSUB) D  SERVAL(VV ROOT,VVSUB ) Q
  23321   "RTN","VPR JSONE",34, 0)
  23322    . ; other wise navig ate to the  next chil d object o r array
  23323   "RTN","VPR JSONE",35, 0)
  23324    . I $D(@V VROOT@(VVS UB))=10 S  VVNXT=$O(@ VVROOT@(VV SUB,"")) D   Q
  23325   "RTN","VPR JSONE",36, 0)
  23326    . . I +VV NXT D SERA RY($NA(@VV ROOT@(VVSU B))) I 1
  23327   "RTN","VPR JSONE",37, 0)
  23328    . . E  D  SEROBJ($NA (@VVROOT@( VVSUB)))
  23329   "RTN","VPR JSONE",38, 0)
  23330    . D ERRX( "SOB",VVSU B)  ; shou ld quit lo op before  here
  23331   "RTN","VPR JSONE",39, 0)
  23332    S @VVJSON @(VVLINE)= @VVJSON@(V VLINE)_"}"
  23333   "RTN","VPR JSONE",40, 0)
  23334    Q
  23335   "RTN","VPR JSONE",41, 0)
  23336   SERARY(VVR OOT) ; Ser ialize int o a JSON a rray
  23337   "RTN","VPR JSONE",42, 0)
  23338    N VVFIRST ,VVI,VVNXT
  23339   "RTN","VPR JSONE",43, 0)
  23340    S @VVJSON @(VVLINE)= @VVJSON@(V VLINE)_"["
  23341   "RTN","VPR JSONE",44, 0)
  23342    S VVFIRST =1
  23343   "RTN","VPR JSONE",45, 0)
  23344    S VVI=0 F   S VVI=$O (@VVROOT@( VVI)) Q:'V VI  D
  23345   "RTN","VPR JSONE",46, 0)
  23346    . S:'VVFI RST @VVJSO N@(VVLINE) =@VVJSON@( VVLINE)_", " S VVFIRS T=0
  23347   "RTN","VPR JSONE",47, 0)
  23348    . I $$ISV ALUE(VVROO T,VVI) D S ERVAL(VVRO OT,VVI) Q   ; write v alue
  23349   "RTN","VPR JSONE",48, 0)
  23350    . I $D(@V VROOT@(VVI ))=10 S VV NXT=$O(@VV ROOT@(VVI, "")) D  Q
  23351   "RTN","VPR JSONE",49, 0)
  23352    . . I +VV NXT D SERA RY($NA(@VV ROOT@(VVI) )) I 1
  23353   "RTN","VPR JSONE",50, 0)
  23354    . . E  D  SEROBJ($NA (@VVROOT@( VVI)))
  23355   "RTN","VPR JSONE",51, 0)
  23356    . D ERRX( "SAR",VVI)   ; should  quit loop  before he re
  23357   "RTN","VPR JSONE",52, 0)
  23358    S @VVJSON @(VVLINE)= @VVJSON@(V VLINE)_"]"
  23359   "RTN","VPR JSONE",53, 0)
  23360    Q
  23361   "RTN","VPR JSONE",54, 0)
  23362   SERNAME(VV SUB) ; Ser ialize the  object na me into JS ON string
  23363   "RTN","VPR JSONE",55, 0)
  23364    I $E(VVSU B)="""" S  VVSUB=$E(V VSUB,2,$L( VVSUB)) ;  quote indi cates nume ric label
  23365   "RTN","VPR JSONE",56, 0)
  23366    I ($L(VVS UB)+$L(@VV JSON@(VVLI NE)))>VVMA X S VVLINE =VVLINE+1, @VVJSON@(V VLINE)=""
  23367   "RTN","VPR JSONE",57, 0)
  23368    S @VVJSON @(VVLINE)= @VVJSON@(V VLINE)_""" "_VVSUB_"" ""_":"
  23369   "RTN","VPR JSONE",58, 0)
  23370    Q
  23371   "RTN","VPR JSONE",59, 0)
  23372   SERVAL(VVR OOT,VVSUB)  ; Seriali ze X into  appropriat e JSON rep resentatio n
  23373   "RTN","VPR JSONE",60, 0)
  23374    N VVX,VVI ,VVDONE
  23375   "RTN","VPR JSONE",61, 0)
  23376    ; if the  node is al ready in J SON format , just add  it
  23377   "RTN","VPR JSONE",62, 0)
  23378    I $D(@VVR OOT@(VVSUB ,":")) D   QUIT  ; <- - jump out  here if p reformatte d
  23379   "RTN","VPR JSONE",63, 0)
  23380    . S VVX=$ G(@VVROOT@ (VVSUB,":" )) D:$L(VV X) CONCAT
  23381   "RTN","VPR JSONE",64, 0)
  23382    . S VVI=0  F  S VVI= $O(@VVROOT @(VVSUB,": ",VVI)) Q: 'VVI  S VV X=@VVROOT@ (VVSUB,":" ,VVI) D CO NCAT
  23383   "RTN","VPR JSONE",65, 0)
  23384    ;
  23385   "RTN","VPR JSONE",66, 0)
  23386    S VVX=$G( @VVROOT@(V VSUB)),VVD ONE=0
  23387   "RTN","VPR JSONE",67, 0)
  23388    ; handle  the numeri c, boolean , and null  types
  23389   "RTN","VPR JSONE",68, 0)
  23390    I $D(@VVR OOT@(VVSUB ,"\n")) S: $L(@VVROOT @(VVSUB,"\ n")) VVX=@ VVROOT@(VV SUB,"\n")  D CONCAT Q UIT  ; whe n +X'=X
  23391   "RTN","VPR JSONE",69, 0)
  23392    I '$D(@VV ROOT@(VVSU B,"\s")),$ L(VVX) D   QUIT:VVDON E
  23393   "RTN","VPR JSONE",70, 0)
  23394    . I VVX'] ]$C(1) S V VX=$$JNUM( VVX) D CON CAT S VVDO NE=1 QUIT
  23395   "RTN","VPR JSONE",71, 0)
  23396    . I VVX=" true"!(VVX ="false")! (VVX="null ") D CONCA T S VVDONE =1 QUIT
  23397   "RTN","VPR JSONE",72, 0)
  23398    ; otherwi se treat i t as a str ing type
  23399   "RTN","VPR JSONE",73, 0)
  23400    S VVX=""" "_$$ESC(VV X) ; open  quote
  23401   "RTN","VPR JSONE",74, 0)
  23402    D CONCAT
  23403   "RTN","VPR JSONE",75, 0)
  23404    I $D(@VVR OOT@(VVSUB ,"\")) D   ; handle c ontinuatio n nodes
  23405   "RTN","VPR JSONE",76, 0)
  23406    . S VVI=0  F  S VVI= $O(@VVROOT @(VVSUB,"\ ",VVI)) Q: 'VVI   D
  23407   "RTN","VPR JSONE",77, 0)
  23408    . . S VVX =$$ESC(@VV ROOT@(VVSU B,"\",VVI) )
  23409   "RTN","VPR JSONE",78, 0)
  23410    . . D CON CAT
  23411   "RTN","VPR JSONE",79, 0)
  23412    S VVX=""" " D CONCAT     ; clos e quote
  23413   "RTN","VPR JSONE",80, 0)
  23414    Q
  23415   "RTN","VPR JSONE",81, 0)
  23416   CONCAT ; c ome here t o concaten ate to JSO N string
  23417   "RTN","VPR JSONE",82, 0)
  23418    I ($L(VVX )+$L(@VVJS ON@(VVLINE )))>VVMAX  S VVLINE=V VLINE+1,@V VJSON@(VVL INE)=""
  23419   "RTN","VPR JSONE",83, 0)
  23420    S @VVJSON @(VVLINE)= @VVJSON@(V VLINE)_VVX
  23421   "RTN","VPR JSONE",84, 0)
  23422    Q
  23423   "RTN","VPR JSONE",85, 0)
  23424   ISVALUE(VV ROOT,VVSUB ) ; Return  true if t his is a v alue node
  23425   "RTN","VPR JSONE",86, 0)
  23426    I $D(@VVR OOT@(VVSUB ))#2 Q 1
  23427   "RTN","VPR JSONE",87, 0)
  23428    N VVX S V VX=$O(@VVR OOT@(VVSUB ,""))
  23429   "RTN","VPR JSONE",88, 0)
  23430    Q:VVX="\"  1  ; word  processin g continua tion node
  23431   "RTN","VPR JSONE",89, 0)
  23432    Q:VVX=":"  1  ; pre- formatted  JSON node
  23433   "RTN","VPR JSONE",90, 0)
  23434    Q 0
  23435   "RTN","VPR JSONE",91, 0)
  23436    ;
  23437   "RTN","VPR JSONE",92, 0)
  23438   NUMERIC(X)  ; Return  true if th e numeric
  23439   "RTN","VPR JSONE",93, 0)
  23440    I $L(X)>1 8 Q 0         ; strin g (too lon g for nume ric)
  23441   "RTN","VPR JSONE",94, 0)
  23442    I X=0 Q 1               ; numer ic (value  is zero)
  23443   "RTN","VPR JSONE",95, 0)
  23444    I +X=0 Q  0             ; strin g
  23445   "RTN","VPR JSONE",96, 0)
  23446    I $E(X,1) ="." Q 0      ; not a  JSON numb er (althou gh numeric  in M)
  23447   "RTN","VPR JSONE",97, 0)
  23448    I $E(X,1, 2)="-." Q  0  ; not a  JSON numb er
  23449   "RTN","VPR JSONE",98, 0)
  23450    I +X=X Q  1             ; numer ic
  23451   "RTN","VPR JSONE",99, 0)
  23452    I X?1"0." 1.n Q 1       ; posit ive fracti on
  23453   "RTN","VPR JSONE",100 ,0)
  23454    I X?1"-0. "1.N Q 1      ; negat ive fracti on
  23455   "RTN","VPR JSONE",101 ,0)
  23456    S X=$TR(X ,"e","E")
  23457   "RTN","VPR JSONE",102 ,0)
  23458    I X?.1"-" 1.N.1".".N 1"E".1"+"1 .N Q 1  ;  {-}99{.99} E{+}99
  23459   "RTN","VPR JSONE",103 ,0)
  23460    I X?.1"-" 1.N.1".".N 1"E-"1.N Q  1      ;  {-}99{.99} E-99
  23461   "RTN","VPR JSONE",104 ,0)
  23462    Q 0
  23463   "RTN","VPR JSONE",105 ,0)
  23464    ;
  23465   "RTN","VPR JSONE",106 ,0)
  23466   ESC(X) ; E scape stri ng for JSO N
  23467   "RTN","VPR JSONE",107 ,0)
  23468    N Y,I,PAI R,FROM,TO
  23469   "RTN","VPR JSONE",108 ,0)
  23470    S Y=X
  23471   "RTN","VPR JSONE",109 ,0)
  23472    F PAIR="\ \","""""", "//",$C(8, 98),$C(12, 102),$C(10 ,110),$C(1 3,114),$C( 9,116) D
  23473   "RTN","VPR JSONE",110 ,0)
  23474    . S FROM= $E(PAIR),T O=$E(PAIR, 2)
  23475   "RTN","VPR JSONE",111 ,0)
  23476    . S X=Y,Y =$P(X,FROM ) F I=2:1: $L(X,FROM)  S Y=Y_"\" _TO_$P(X,F ROM,I)
  23477   "RTN","VPR JSONE",112 ,0)
  23478    I Y?.E1.C .E S X=Y,Y ="" F I=1: 1:$L(X) S  FROM=$A(X, I) D
  23479   "RTN","VPR JSONE",113 ,0)
  23480    . ; skip  NUL charac ter, other wise encod e ctrl-cha r
  23481   "RTN","VPR JSONE",114 ,0)
  23482    . I FROM< 32 Q:FROM= 0  S Y=Y_$ $UCODE(FRO M) Q
  23483   "RTN","VPR JSONE",115 ,0)
  23484    . I FROM> 126,(FROM< 160) S Y=Y _$$UCODE(F ROM) Q
  23485   "RTN","VPR JSONE",116 ,0)
  23486    . S Y=Y_$ E(X,I)
  23487   "RTN","VPR JSONE",117 ,0)
  23488    Q Y
  23489   "RTN","VPR JSONE",118 ,0)
  23490    ;
  23491   "RTN","VPR JSONE",119 ,0)
  23492   JNUM(N) ;  Return JSO N represen tation of  a number
  23493   "RTN","VPR JSONE",120 ,0)
  23494    I N'<1 Q  N
  23495   "RTN","VPR JSONE",121 ,0)
  23496    I N'>-1 Q  N
  23497   "RTN","VPR JSONE",122 ,0)
  23498    I N>0 Q " 0"_N
  23499   "RTN","VPR JSONE",123 ,0)
  23500    I N<0 Q " -0"_$P(N," -",2,9)
  23501   "RTN","VPR JSONE",124 ,0)
  23502    Q N
  23503   "RTN","VPR JSONE",125 ,0)
  23504    ;
  23505   "RTN","VPR JSONE",126 ,0)
  23506   UCODE(C) ;  Return \u 00nn repre sentation  of decimal  character  value
  23507   "RTN","VPR JSONE",127 ,0)
  23508    N H S H=" 0000"_$$CN V^XLFUTL(C ,16)
  23509   "RTN","VPR JSONE",128 ,0)
  23510    Q "\u"_$E (H,$L(H)-3 ,$L(H))
  23511   "RTN","VPR JSONE",129 ,0)
  23512    ;
  23513   "RTN","VPR JSONE",130 ,0)
  23514   ERRX(ID,VA L) ; Set t he appropr iate error  message
  23515   "RTN","VPR JSONE",131 ,0)
  23516    D ERRX^VP RJSON(ID,$ G(VAL))
  23517   "RTN","VPR JSONE",132 ,0)
  23518    Q
  23519   "RTN","VPR MDUTL")
  23520   0^58^B5094 9812
  23521   "RTN","VPR MDUTL",1,0 )
  23522   VPRMDUTL ; HINES OIFO /BLJ - Fil eMan JSON  utilities  for HMP;02  April 201 3
  23523   "RTN","VPR MDUTL",2,0 )
  23524    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  23525   "RTN","VPR MDUTL",3,0 )
  23526    ; Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  23527   "RTN","VPR MDUTL",4,0 )
  23528    ;
  23529   "RTN","VPR MDUTL",5,0 )
  23530   EN Q  ; On ly call vi a linetag.
  23531   "RTN","VPR MDUTL",6,0 )
  23532   TERM ; Ret rieves lis t of terms
  23533   "RTN","VPR MDUTL",7,0 )
  23534     ; NOTE:  we're not  gonna supp ort paged  retrieves  with this  unless we  have to.   Do not cou nt on
  23535   "RTN","VPR MDUTL",8,0 )
  23536     ; them b eing there .
  23537   "RTN","VPR MDUTL",9,0 )
  23538     ;
  23539   "RTN","VPR MDUTL",10, 0)
  23540     ; Gets t erminology .
  23541   "RTN","VPR MDUTL",11, 0)
  23542     N TERMIE NS,TERMCNT ,X
  23543   "RTN","VPR MDUTL",12, 0)
  23544     D LIST^D IC("704.10 1",,,,,,,, "I $P(^(0) ,U,5)=1")
  23545   "RTN","VPR MDUTL",13, 0)
  23546     M TERMIE NS=^TMP("D ILIST",$J, 2)
  23547   "RTN","VPR MDUTL",14, 0)
  23548     S TERMCN T=$P($G(^T MP("DILIST ",$J,0)),U ,1)
  23549   "RTN","VPR MDUTL",15, 0)
  23550     K ^TMP(" DILIST",$J )
  23551   "RTN","VPR MDUTL",16, 0)
  23552     ;
  23553   "RTN","VPR MDUTL",17, 0)
  23554     F X=0:0  S X=$O(TER MIENS(X))  Q:'X  D
  23555   "RTN","VPR MDUTL",18, 0)
  23556     . N RESU LT
  23557   "RTN","VPR MDUTL",19, 0)
  23558     . ; term
  23559   "RTN","VPR MDUTL",20, 0)
  23560     . D ONET ERM($G(TER MIENS(X)), "RESULT")
  23561   "RTN","VPR MDUTL",21, 0)
  23562     . ;
  23563   "RTN","VPR MDUTL",22, 0)
  23564     . D ADD^ VPREF("RES ULT")
  23565   "RTN","VPR MDUTL",23, 0)
  23566     . S VPRC NT=X,VPRLA ST=X
  23567   "RTN","VPR MDUTL",24, 0)
  23568     I 'X S V PRFINI=1
  23569   "RTN","VPR MDUTL",25, 0)
  23570     Q
  23571   "RTN","VPR MDUTL",26, 0)
  23572   ONETERM(ID ,TARGET) ;  loads one  term
  23573   "RTN","VPR MDUTL",27, 0)
  23574     Q:+ID<1   ; Gotta b e a valid  integer/id
  23575   "RTN","VPR MDUTL",28, 0)
  23576     N $ES,$E T,ERRMSG
  23577   "RTN","VPR MDUTL",29, 0)
  23578     S ERRMSG =$$ERRMSG^ VPREF("CLi O Term",ID )
  23579   "RTN","VPR MDUTL",30, 0)
  23580     S $ET="D  ERRHDLR^V PRDERRH"
  23581   "RTN","VPR MDUTL",31, 0)
  23582     N TERM,T RM,TERMTYP E
  23583   "RTN","VPR MDUTL",32, 0)
  23584     ;
  23585   "RTN","VPR MDUTL",33, 0)
  23586     D GETS^D IQ("704.10 1",ID_",", "*","IE"," TERM")
  23587   "RTN","VPR MDUTL",34, 0)
  23588     N TRM S  TRM=$NA(TE RM(704.101 ,""_ID_"," ))
  23589   "RTN","VPR MDUTL",35, 0)
  23590     S @TARGE T@("id")=$ G(@TRM@(.0 1,"E"))
  23591   "RTN","VPR MDUTL",36, 0)
  23592     S @TARGE T@("uid")= "urn:va:cl ioterminol ogy:"_$G(@ TARGET@("i d"))
  23593   "RTN","VPR MDUTL",37, 0)
  23594     S @TARGE T@("term") =$$SANITIZ E($G(@TRM@ (.02,"E")) )
  23595   "RTN","VPR MDUTL",38, 0)
  23596     S @TARGE T@("abbrev iation")=$ $SANITIZE( $G(@TRM@(. 03,"E")))
  23597   "RTN","VPR MDUTL",39, 0)
  23598     S @TARGE T@("displa yName")=$$ SANITIZE($ G(@TRM@(.0 4,"E")))
  23599   "RTN","VPR MDUTL",40, 0)
  23600     ; Get Te rm Type
  23601   "RTN","VPR MDUTL",41, 0)
  23602     S TERMTY PE=$$SANIT IZE($G(@TR M@(.05,"I" )))
  23603   "RTN","VPR MDUTL",42, 0)
  23604     D TERMTY PE(TERMTYP E,.TARGET)
  23605   "RTN","VPR MDUTL",43, 0)
  23606     ;
  23607   "RTN","VPR MDUTL",44, 0)
  23608     S @TARGE T@("dataTy pe")=$$SAN ITIZE($G(@ TRM@(.06," I")))
  23609   "RTN","VPR MDUTL",45, 0)
  23610     S @TARGE T@("valueT ype")=$$SA NITIZE($G( @TRM@(.07, "I")))
  23611   "RTN","VPR MDUTL",46, 0)
  23612     S @TARGE T@("active ")=$$SANIT IZE($G(@TR M@(.09,"E" )))
  23613   "RTN","VPR MDUTL",47, 0)
  23614     S @TARGE T@("descri ption")=$$ SANITIZE($ G(@TRM@(.1 ,"E")))
  23615   "RTN","VPR MDUTL",48, 0)
  23616     S @TARGE T@("helpTe xt")=$$SAN ITIZE($G(@ TRM@(.2,"E ")))
  23617   "RTN","VPR MDUTL",49, 0)
  23618     S @TARGE T@("boolea nValueTrue ")=$$SANIT IZE($G(@TR M@(.31,"E" )))
  23619   "RTN","VPR MDUTL",50, 0)
  23620     S @TARGE T@("boolea nValueFals e")=$$SANI TIZE($G(@T RM@(.32,"E ")))
  23621   "RTN","VPR MDUTL",51, 0)
  23622     S @TARGE T@("multiS electPickl ist")=$$SA NITIZE($G( @TRM@(.33, "E")))
  23623   "RTN","VPR MDUTL",52, 0)
  23624     S @TARGE T@("VUID") ="urn:va:v uid:"_$$SA NITIZE($G( @TRM@(99.9 9,"E")))
  23625   "RTN","VPR MDUTL",53, 0)
  23626     ; term - > child te rms
  23627   "RTN","VPR MDUTL",54, 0)
  23628     ;
  23629   "RTN","VPR MDUTL",55, 0)
  23630     ; Note,  for right  now this i s a little  odd: the  initial lo ad is done  off of DF N.  This l oad
  23631   "RTN","VPR MDUTL",56, 0)
  23632     ; is don e off of U ID.  We'll  probably  change tha t to UID o r IFN for  both at so me point.
  23633   "RTN","VPR MDUTL",57, 0)
  23634     ;
  23635   "RTN","VPR MDUTL",58, 0)
  23636     D TERMCH LD($G(@TRM @(.01,"E") ),.TARGET)
  23637   "RTN","VPR MDUTL",59, 0)
  23638     ;
  23639   "RTN","VPR MDUTL",60, 0)
  23640     ; term - > unit pai r
  23641   "RTN","VPR MDUTL",61, 0)
  23642     D TERMUN IT($G(@TRM @(.01,"E") ),.TARGET)
  23643   "RTN","VPR MDUTL",62, 0)
  23644     ;
  23645   "RTN","VPR MDUTL",63, 0)
  23646     ; term - > qualifie r pair
  23647   "RTN","VPR MDUTL",64, 0)
  23648     ;
  23649   "RTN","VPR MDUTL",65, 0)
  23650     D TERMQU AL($G(@TRM @(.01,"E") ),.TARGET, ID)
  23651   "RTN","VPR MDUTL",66, 0)
  23652     ;
  23653   "RTN","VPR MDUTL",67, 0)
  23654     ; term - > unit con version -  for right  now, we're  not going  to pull t erm -> uni t conversi ons.  We w ill need t o do so at  some poin t
  23655   "RTN","VPR MDUTL",68, 0)
  23656     ; though .
  23657   "RTN","VPR MDUTL",69, 0)
  23658     K TERMTY PE,TRM
  23659   "RTN","VPR MDUTL",70, 0)
  23660     Q
  23661   "RTN","VPR MDUTL",71, 0)
  23662     ;
  23663   "RTN","VPR MDUTL",72, 0)
  23664   TERMTYPE(I D,TARGET)  ;Loads ter m types.
  23665   "RTN","VPR MDUTL",73, 0)
  23666     ;
  23667   "RTN","VPR MDUTL",74, 0)
  23668     ; TARGET  passed by  reference .  
  23669   "RTN","VPR MDUTL",75, 0)
  23670     ;
  23671   "RTN","VPR MDUTL",76, 0)
  23672     ; Sanity  checks fi rst
  23673   "RTN","VPR MDUTL",77, 0)
  23674     ; 
  23675   "RTN","VPR MDUTL",78, 0)
  23676     Q:+ID<1   ; Gotta b e a number , we're do ing a dire ct IFN loo kup.
  23677   "RTN","VPR MDUTL",79, 0)
  23678     N TERMTY PE
  23679   "RTN","VPR MDUTL",80, 0)
  23680     D GETS^D IQ("704.10 2",ID_",", "*","E","T ERMTYPE")
  23681   "RTN","VPR MDUTL",81, 0)
  23682     N VPRNAM E S VPRNAM E=$T(TTFLD S+1)
  23683   "RTN","VPR MDUTL",82, 0)
  23684     ;
  23685   "RTN","VPR MDUTL",83, 0)
  23686     N VPREPL AC S VPREP LAC("""")= "\"""
  23687   "RTN","VPR MDUTL",84, 0)
  23688     S @TARGE T@("termTy pe",$P(VPR NAME,";",3 ))=ID
  23689   "RTN","VPR MDUTL",85, 0)
  23690     S @TARGE T@("termTy pe",$P(VPR NAME,";",4 ))=$$SANIT IZE($$REPL ACE^XLFSTR (TERMTYPE( "704.102", ID_",",.01 ,"E"),.VPR EPLAC))
  23691   "RTN","VPR MDUTL",86, 0)
  23692     S @TARGE T@("termTy pe",$P(VPR NAME,";",5 ))=$$SANIT IZE($$REPL ACE^XLFSTR (TERMTYPE( "704.102", ID_",",.02 ,"E"),.VPR EPLAC))
  23693   "RTN","VPR MDUTL",87, 0)
  23694     S @TARGE T@("termTy pe",$P(VPR NAME,";",6 ))=$$SANIT IZE($$REPL ACE^XLFSTR (TERMTYPE( "704.102", ID_",",.03 ,"E"),.VPR EPLAC))
  23695   "RTN","VPR MDUTL",88, 0)
  23696     K TERMTY PE
  23697   "RTN","VPR MDUTL",89, 0)
  23698     Q
  23699   "RTN","VPR MDUTL",90, 0)
  23700   TERMCHLD(I D,TARGET)  ;Loads chi ld terms f or a term
  23701   "RTN","VPR MDUTL",91, 0)
  23702     ;
  23703   "RTN","VPR MDUTL",92, 0)
  23704     ;
  23705   "RTN","VPR MDUTL",93, 0)
  23706     N MSGROO T S MSGROO T="TERMCHL D("""_ID_" "")"
  23707   "RTN","VPR MDUTL",94, 0)
  23708     D FIND^D IC("704.10 6",,".02E; .03I;.04I; .05E;.06E; .07E;.08E; .09E","M", ID,,,,,MSG ROOT)
  23709   "RTN","VPR MDUTL",95, 0)
  23710     ; Check  to see if  we actuall y have any  children.
  23711   "RTN","VPR MDUTL",96, 0)
  23712     I +$P(TE RMCHLD(ID, "DILIST",0 ),U,1)<1 K  @MSGROOT  Q
  23713   "RTN","VPR MDUTL",97, 0)
  23714     N X F X= 0:0 S X=($ O(TERMCHLD (ID,"DILIS T","ID",X) )) Q:'X  D
  23715   "RTN","VPR MDUTL",98, 0)
  23716     . ; .01  is the Ter m ID
  23717   "RTN","VPR MDUTL",99, 0)
  23718     . S @TAR GET@("term Child",X," childOrder ")=$$SANIT IZE($G(TER MCHLD(ID," DILIST","I D",X,.02)) )
  23719   "RTN","VPR MDUTL",100 ,0)
  23720     . ; .03  is the Chi ld ID
  23721   "RTN","VPR MDUTL",101 ,0)
  23722     . N CHIL D S CHILD= $NA(@TARGE T@("termCh ild",X,"ch ildTerm"))
  23723   "RTN","VPR MDUTL",102 ,0)
  23724     . D ONET ERM($G(TER MCHLD(ID," DILIST","I D",X,.03)) ,.CHILD)
  23725   "RTN","VPR MDUTL",103 ,0)
  23726     . S @TAR GET@("term Child",X," valueType" )=$$SANITI ZE($G(TERM CHLD(ID,"D ILIST","ID ",X,.05)))
  23727   "RTN","VPR MDUTL",104 ,0)
  23728     . S @TAR GET@("term Child",X," valueDelim iter")=$$S ANITIZE($G (TERMCHLD( ID,"DILIST ","ID",X,. 06)))
  23729   "RTN","VPR MDUTL",105 ,0)
  23730     . S @TAR GET@("term Child",X," valueStart ")=$$SANIT IZE($G(TER MCHLD(ID," DILIST","I D",X,.07)) )
  23731   "RTN","VPR MDUTL",106 ,0)
  23732     . S @TAR GET@("term Child",X," valueStop" )=$$SANITI ZE($G(TERM CHLD(ID,"D ILIST","ID ",X,.08)))
  23733   "RTN","VPR MDUTL",107 ,0)
  23734     . S @TAR GET@("term Child",X," descriptio n")=$$SANI TIZE($G(TE RMCHLD(ID, "DILIST"," ID",X,.09) ))
  23735   "RTN","VPR MDUTL",108 ,0)
  23736     K @MSGRO OT
  23737   "RTN","VPR MDUTL",109 ,0)
  23738     Q
  23739   "RTN","VPR MDUTL",110 ,0)
  23740   TERMUNIT(I D,TARGET)  ;Loads Uni ts for a t erm.
  23741   "RTN","VPR MDUTL",111 ,0)
  23742    ;
  23743   "RTN","VPR MDUTL",112 ,0)
  23744    N MSGROOT  S MSGROOT ="TERMUNIT ("""_ID_"" ")"
  23745   "RTN","VPR MDUTL",113 ,0)
  23746    D FIND^DI C("704.105 ",,".02I;. 03E;.04E;. 05E;.06E;. 07E","M",I D,,,,,MSGR OOT)
  23747   "RTN","VPR MDUTL",114 ,0)
  23748    ; Check t o see if w e actually  have any  children.
  23749   "RTN","VPR MDUTL",115 ,0)
  23750    I +$P(TER MUNIT(ID," DILIST",0) ,U,1)<1 K  @MSGROOT Q
  23751   "RTN","VPR MDUTL",116 ,0)
  23752    N X F X=0 :0 S X=($O (TERMUNIT( ID,"DILIST ","ID",X)) ) Q:'X  D
  23753   "RTN","VPR MDUTL",117 ,0)
  23754    . ; .01 i s the Term  ID
  23755   "RTN","VPR MDUTL",118 ,0)
  23756    . ; .02 i s the Unit  ID
  23757   "RTN","VPR MDUTL",119 ,0)
  23758    . N UNIT  S UNIT=$NA (@TARGET@( "units",X, "unitTerm" ))
  23759   "RTN","VPR MDUTL",120 ,0)
  23760    . D ONETE RM($G(TERM UNIT(ID,"D ILIST","ID ",X,.02)), .UNIT)
  23761   "RTN","VPR MDUTL",121 ,0)
  23762    . S @TARG ET@("units ",X,"minVa lue")=$$SA NITIZE($G( TERMUNIT(I D,"DILIST" ,"ID",X,.0 3)))
  23763   "RTN","VPR MDUTL",122 ,0)
  23764    . S @TARG ET@("units ",X,"maxVa lue")=$$SA NITIZE($G( TERMUNIT(I D,"DILIST" ,"ID",X,.0 4)))
  23765   "RTN","VPR MDUTL",123 ,0)
  23766    . S @TARG ET@("units ",X,"decPr ecision")= $$SANITIZE ($G(TERMUN IT(ID,"DIL IST","ID", X,.05)))
  23767   "RTN","VPR MDUTL",124 ,0)
  23768    . S @TARG ET@("units ",X,"refLo w")=$$SANI TIZE($G(TE RMUNIT(ID, "DILIST"," ID",X,.06) ))
  23769   "RTN","VPR MDUTL",125 ,0)
  23770    . S @TARG ET@("units ",X,"refHi gh")=$$SAN ITIZE($G(T ERMUNIT(ID ,"DILIST", "ID",X,.07 )))
  23771   "RTN","VPR MDUTL",126 ,0)
  23772    K @MSGROO T
  23773   "RTN","VPR MDUTL",127 ,0)
  23774    Q
  23775   "RTN","VPR MDUTL",128 ,0)
  23776   TERMQUAL(I D,TARGET,I FN) ;Loads  Qualifier s for a te rm
  23777   "RTN","VPR MDUTL",129 ,0)
  23778    ;
  23779   "RTN","VPR MDUTL",130 ,0)
  23780    N MSGROOT  S MSGROOT ="TERMQUAL ("""_ID_"" ")"
  23781   "RTN","VPR MDUTL",131 ,0)
  23782    D FIND^DI C("704.103 ",,".02E;. 03I;.04E", "M",ID,,,, ,MSGROOT)
  23783   "RTN","VPR MDUTL",132 ,0)
  23784    ; Check t o see if w e actually  have any  qualifiers .
  23785   "RTN","VPR MDUTL",133 ,0)
  23786    I +$P(TER MQUAL(ID," DILIST",0) ,U,1)<1 K  @MSGROOT Q
  23787   "RTN","VPR MDUTL",134 ,0)
  23788    N X F X=0 :0 S X=($O (TERMQUAL( ID,"DILIST ","ID",X)) ) Q:'X  D
  23789   "RTN","VPR MDUTL",135 ,0)
  23790    . ; .01 i s the Term  ID
  23791   "RTN","VPR MDUTL",136 ,0)
  23792    . ; .03 i s the Qual ifier ID
  23793   "RTN","VPR MDUTL",137 ,0)
  23794    . N QUAL  S QUAL=$NA (@TARGET@( "qualifier s",X,"qual Term"))
  23795   "RTN","VPR MDUTL",138 ,0)
  23796    . ; blj 2 8 Feb 2014 : bandaid  to prevent  recursive  calls if  someone ha s messed u p the stru cture of t he TERM_QU ALIFIER fi le.
  23797   "RTN","VPR MDUTL",139 ,0)
  23798    . I IFN'= $G(TERMQUA L(ID,"DILI ST","ID",X ,.03)) D O NETERM($G( TERMQUAL(I D,"DILIST" ,"ID",X,.0 3)),.QUAL)
  23799   "RTN","VPR MDUTL",140 ,0)
  23800    . S @TARG ET@("quali fiers",X," qualOrder" )=$$SANITI ZE($G(TERM QUAL(ID,"D ILIST","ID ",X,.02)))
  23801   "RTN","VPR MDUTL",141 ,0)
  23802    . S @TARG ET@("quali fiers",X," ranking")= $$SANITIZE ($G(TERMQU AL(ID,"DIL IST","ID", X,.04)))
  23803   "RTN","VPR MDUTL",142 ,0)
  23804    K @MSGROO T
  23805   "RTN","VPR MDUTL",143 ,0)
  23806    Q
  23807   "RTN","VPR MDUTL",144 ,0)
  23808   SANITIZE(V ALUE) ; Ma kes sure v alues are  formatted  correctly.
  23809   "RTN","VPR MDUTL",145 ,0)
  23810    I +VALUE' =VALUE Q V ALUE
  23811   "RTN","VPR MDUTL",146 ,0)
  23812    I VALUE?1 ".".N S VA LUE="0"_VA LUE
  23813   "RTN","VPR MDUTL",147 ,0)
  23814    I VALUE?1 "-.".N S V ALUE="-0"_ $E(VALUE,2 ,$LENGTH(V ALUE))
  23815   "RTN","VPR MDUTL",148 ,0)
  23816    Q VALUE
  23817   "RTN","VPR MDUTL",149 ,0)
  23818    ;
  23819   "RTN","VPR MDUTL",150 ,0)
  23820   GENGUID()  ;
  23821   "RTN","VPR MDUTL",151 ,0)
  23822    N X,AB
  23823   "RTN","VPR MDUTL",152 ,0)
  23824    S X="",AB =$R(4),AB= $S(AB=0:"8 ",AB=1:"9" ,AB=2:"A", 1:"B")
  23825   "RTN","VPR MDUTL",153 ,0)
  23826    F  S X=X_ $$BASE^XLF UTL($R(16) ,10,16) Q: $L(X)>31
  23827   "RTN","VPR MDUTL",154 ,0)
  23828    S X="{"_$ E(X,1,8)_" -"_$E(X,9, 12)_"-"_"4 "_$E(X,14, 16)_"-"_AB _$E(X,18,2 0)_"-"_$E( X,21,32)_" }"
  23829   "RTN","VPR MDUTL",155 ,0)
  23830    Q X
  23831   "RTN","VPR MDUTL",156 ,0)
  23832   TRMFLDS ;F ields for  terminolog y
  23833   "RTN","VPR MDUTL",157 ,0)
  23834     ;;.01;id
  23835   "RTN","VPR MDUTL",158 ,0)
  23836     ;;.02;te rm
  23837   "RTN","VPR MDUTL",159 ,0)
  23838     ;;.03;ab breviation
  23839   "RTN","VPR MDUTL",160 ,0)
  23840     ;;.04;di splayName
  23841   "RTN","VPR MDUTL",161 ,0)
  23842     ;;.05;te rmType
  23843   "RTN","VPR MDUTL",162 ,0)
  23844     ;;.06;da taType
  23845   "RTN","VPR MDUTL",163 ,0)
  23846     ;;.07;va lueType
  23847   "RTN","VPR MDUTL",164 ,0)
  23848     ;;.09;ac tive
  23849   "RTN","VPR MDUTL",165 ,0)
  23850     ;;.1;des cription
  23851   "RTN","VPR MDUTL",166 ,0)
  23852     ;;.2;hel pText;
  23853   "RTN","VPR MDUTL",167 ,0)
  23854     ;;.31;bo oleanValue True
  23855   "RTN","VPR MDUTL",168 ,0)
  23856     ;;.32;bo oleanValue False;
  23857   "RTN","VPR MDUTL",169 ,0)
  23858     ;;.33;mu ltiSelectP icklist
  23859   "RTN","VPR MDUTL",170 ,0)
  23860     ;;99.99; VUID
  23861   "RTN","VPR MDUTL",171 ,0)
  23862     ;;***
  23863   "RTN","VPR MDUTL",172 ,0)
  23864   TTFLDS ;Fi elds for T erm Typea
  23865   "RTN","VPR MDUTL",173 ,0)
  23866     ;;id;typ e;xmlTag;V UID
  23867   "RTN","VPR P3I")
  23868   0^^B635834 07
  23869   "RTN","VPR P3I",1,0)
  23870   VPRP3I ;SL C/AGP -- V PR patch 3  post inst all
  23871   "RTN","VPR P3I",2,0)
  23872    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  23873   "RTN","VPR P3I",3,0)
  23874    ;
  23875   "RTN","VPR P3I",4,0)
  23876   ENV ; -- e nvironment  check to  prevent pr oduction i nstallatio n
  23877   "RTN","VPR P3I",5,0)
  23878    I $$PROD^ XUPROD D
  23879   "RTN","VPR P3I",6,0)
  23880    .W !,"You  are attem pting to i nstall thi s software  into your  productio n account. ",!,"At th is time, t his softwa re is not  ready for  a producti on install ."
  23881   "RTN","VPR P3I",7,0)
  23882    .W !!,"Pl ease verif y the acco unt you're  attemptin g to insta ll into an d",!,"if y ou believe  you're co rrect, con tact Ron M assey or T ana Defa." ,!!,"INSTA LLATION AB ORTED!"
  23883   "RTN","VPR P3I",8,0)
  23884    .S XPDABO RT=1
  23885   "RTN","VPR P3I",9,0)
  23886    Q
  23887   "RTN","VPR P3I",10,0)
  23888    ;
  23889   "RTN","VPR P3I",11,0)
  23890   PRE ; -- c lean out V PR SUBSCRI PTION and  ^XTMP("VPR ") entries  for testi ng
  23891   "RTN","VPR P3I",12,0)
  23892    N VPRDT S  VPRDT="VP R-1111111"
  23893   "RTN","VPR P3I",13,0)
  23894    F  S VPRD T=$O(^XTMP (VPRDT)) Q :VPRDT'?1" VPR-"7N  K  ^XTMP(VPR DT)
  23895   "RTN","VPR P3I",14,0)
  23896    S VPRDT=" VPREF-1111 111"
  23897   "RTN","VPR P3I",15,0)
  23898    F  S VPRD T=$O(^XTMP (VPRDT)) Q :VPRDT'?1" VPREF-"7N   K ^XTMP(V PRDT)
  23899   "RTN","VPR P3I",16,0)
  23900    K ^XTMP(" VPR"),^TMP ("VPRX")
  23901   "RTN","VPR P3I",17,0)
  23902    I $$VERCM P($$VERSRV (),"0.7-S5 4")>0 D  ;  if curren t < S54
  23903   "RTN","VPR P3I",18,0)
  23904    . K ^VPR( 560)
  23905   "RTN","VPR P3I",19,0)
  23906    . S ^VPR( 560,0)="VP R SUBSCRIP TION^560^^ "
  23907   "RTN","VPR P3I",20,0)
  23908    ;D CLEARP AR
  23909   "RTN","VPR P3I",21,0)
  23910    I $D(^DD( 560.04)) D   ;remove  old Subscr iption sub -files
  23911   "RTN","VPR P3I",22,0)
  23912    . N DIU S  DIU(0)="S "
  23913   "RTN","VPR P3I",23,0)
  23914    . S DIU=5 60.04 D EN ^DIU2
  23915   "RTN","VPR P3I",24,0)
  23916    . S DIU=5 60.03 D EN ^DIU2
  23917   "RTN","VPR P3I",25,0)
  23918    I $D(^DD( 560.01,.03 )) D  ; re mote old P ID field
  23919   "RTN","VPR P3I",26,0)
  23920    . S DIK=" ^DD(560.01 ,",DA=.03, DA(1)=560. 01
  23921   "RTN","VPR P3I",27,0)
  23922    . D ^DIK
  23923   "RTN","VPR P3I",28,0)
  23924    ;D TASKCO NV
  23925   "RTN","VPR P3I",29,0)
  23926    D ADDRSRC  ; add res ource for  throttling  extract t asks
  23927   "RTN","VPR P3I",30,0)
  23928    Q
  23929   "RTN","VPR P3I",31,0)
  23930    ;
  23931   "RTN","VPR P3I",32,0)
  23932   CLEARPAR ;
  23933   "RTN","VPR P3I",33,0)
  23934    N ENT,ERR OR,INST,LI ST,PAR,TYP E,X,UID
  23935   "RTN","VPR P3I",34,0)
  23936    ;S PAR=""  F  S PAR= $O(^XTV(89 89.51,"B", "VPR PARAM ETERS","") ) I PAR>0  Q
  23937   "RTN","VPR P3I",35,0)
  23938    S PAR=$O( ^XTV(8989. 51,"B","VP R PARAMETE RS","")) Q :PAR'>0
  23939   "RTN","VPR P3I",36,0)
  23940    S X="" F   S X=$O(^X TV(8989.5, "AC",PAR,X )) Q:X=""   D
  23941   "RTN","VPR P3I",37,0)
  23942    .S TYPE=$ S(X["VA":" USR",X["DI C":"SYS",1 :"") I TYP E="" Q
  23943   "RTN","VPR P3I",38,0)
  23944    .S ENT=TY PE_".`"_+X
  23945   "RTN","VPR P3I",39,0)
  23946    .S UID=""  F  S UID= $O(^XTV(89 89.5,"AC", PAR,X,UID) ) Q:UID=""   D
  23947   "RTN","VPR P3I",40,0)
  23948    ..D DEL^X PAR(ENT,"V PR PARAMET ERS",UID,. ERROR)
  23949   "RTN","VPR P3I",41,0)
  23950    Q
  23951   "RTN","VPR P3I",42,0)
  23952    ;
  23953   "RTN","VPR P3I",43,0)
  23954    ; VERSRV  and VERCMP  are also  in VPRUTIL S, but not  until aft er the ins tall
  23955   "RTN","VPR P3I",44,0)
  23956    ; of this  patch (VP R*1*3), so  they are  reproduced  here.
  23957   "RTN","VPR P3I",45,0)
  23958    ;
  23959   "RTN","VPR P3I",46,0)
  23960   VERSRV()    ; Return  server ver sion of op tion name
  23961   "RTN","VPR P3I",47,0)
  23962    N VPRLST, VAL
  23963   "RTN","VPR P3I",48,0)
  23964    D FIND^DI C(19,"",1, "X","VPR U I CONTEXT" ,1,,,,"VPR LST")
  23965   "RTN","VPR P3I",49,0)
  23966    S VAL=$G( VPRLST("DI LIST","ID" ,1,1))
  23967   "RTN","VPR P3I",50,0)
  23968    Q $$UP^XL FSTR($P(VA L,"version  ",2))
  23969   "RTN","VPR P3I",51,0)
  23970    ;
  23971   "RTN","VPR P3I",52,0)
  23972   VERCMP(CUR ,VAL) ; Re turns 1 if  CUR<VAL,  -1 if CUR> VAL, 0 if  equal
  23973   "RTN","VPR P3I",53,0)
  23974    N CURMAJO R,CURMINOR ,CURSNAP,V ALMAJOR,VA LMINOR,VAL SNAP
  23975   "RTN","VPR P3I",54,0)
  23976    S CURMAJO R=$P(CUR," -"),CURMIN OR=$P(CUR, "-",2),CUR SNAP=$E($P (CUR,"-",3 ),1,4)="SN AP"
  23977   "RTN","VPR P3I",55,0)
  23978    S VALMAJO R=$P(VAL," -"),VALMIN OR=$P(VAL, "-",2),VAL SNAP=$E($P (VAL,"-",3 ),1,4)="SN AP"
  23979   "RTN","VPR P3I",56,0)
  23980    I $E(VALM INOR)="P"  S VALMINOR =$E(VALMIN OR,2,99)      ; "P"il ot version s (old)
  23981   "RTN","VPR P3I",57,0)
  23982    I $E(CURM INOR)="P"  S CURMINOR =$E(VALMIN OR,2,99)
  23983   "RTN","VPR P3I",58,0)
  23984    I $E(VALM INOR)="S"  S VALMINOR =$E(VALMIN OR,2,99)*1 0  ; "S"pr int versio ns
  23985   "RTN","VPR P3I",59,0)
  23986    I $E(CURM INOR)="S"  S CURMINOR =$E(CURMIN OR,2,99)*1 0
  23987   "RTN","VPR P3I",60,0)
  23988    Q:VALMAJO R>CURMAJOR  1   Q:VAL MAJOR<CURM AJOR -1  ;  compare m ajor versi ons
  23989   "RTN","VPR P3I",61,0)
  23990    Q:VALMINO R>CURMINOR  1   Q:VAL MINOR<CURM INOR -1  ;  compare m inor versi ons
  23991   "RTN","VPR P3I",62,0)
  23992    Q:(CURSNA P&'VALSNAP ) 1  Q:(VA LSNAP&'CUR SNAP) -1 ;  "SNAPSHOT " < releas ed
  23993   "RTN","VPR P3I",63,0)
  23994    Q 0
  23995   "RTN","VPR P3I",64,0)
  23996    ;
  23997   "RTN","VPR P3I",65,0)
  23998    ;
  23999   "RTN","VPR P3I",66,0)
  24000   POST ; --  set up new  Tx data
  24001   "RTN","VPR P3I",67,0)
  24002    ;D CREATE US
  24003   "RTN","VPR P3I",68,0)
  24004    N VPRLVER
  24005   "RTN","VPR P3I",69,0)
  24006    S VPRLVER =$$VERSRV( )
  24007   "RTN","VPR P3I",70,0)
  24008    D VERSION
  24009   "RTN","VPR P3I",71,0)
  24010    D EN^VPRI DX
  24011   "RTN","VPR P3I",72,0)
  24012    D DG
  24013   "RTN","VPR P3I",73,0)
  24014    D OI
  24015   "RTN","VPR P3I",74,0)
  24016    D OBJCNT
  24017   "RTN","VPR P3I",75,0)
  24018    I $$VERCM P(VPRLVER, "0.7-S58") >0 D PARPI D ; if cur rent < S58
  24019   "RTN","VPR P3I",76,0)
  24020    Q
  24021   "RTN","VPR P3I",77,0)
  24022    ;
  24023   "RTN","VPR P3I",78,0)
  24024   VERSION ;  -- update  V# paramet er
  24025   "RTN","VPR P3I",79,0)
  24026    D PUT^XPA R("PKG","V PR VERSION ",1,"1.03" )
  24027   "RTN","VPR P3I",80,0)
  24028    D PUT^XPA R("SYS","V PR SYSTEM  NAME",1,$$ SYS^VPRUTI LS)
  24029   "RTN","VPR P3I",81,0)
  24030    Q
  24031   "RTN","VPR P3I",82,0)
  24032    ;
  24033   "RTN","VPR P3I",83,0)
  24034   DG ; -- ad d Treatmen ts display  group to  Nursing pa rent
  24035   "RTN","VPR P3I",84,0)
  24036    Q:'$O(^OR D(100.98," B","NTX",0 ))
  24037   "RTN","VPR P3I",85,0)
  24038    N DA,DIC, DLAYGO,Y
  24039   "RTN","VPR P3I",86,0)
  24040    S DA(1)=$ O(^ORD(100 .98,"B","N URS",0)) I  'DA(1) K  DA Q
  24041   "RTN","VPR P3I",87,0)
  24042    S:'$D(^OR D(100.98,D A(1),1,0))  ^(0)="^10 0.981P^^"
  24043   "RTN","VPR P3I",88,0)
  24044    S DIC="^O RD(100.98, "_DA(1)_", 1,",DIC(0) ="NLX",DLA YGO=100.98
  24045   "RTN","VPR P3I",89,0)
  24046    S X="NTX"  D ^DIC
  24047   "RTN","VPR P3I",90,0)
  24048    Q
  24049   "RTN","VPR P3I",91,0)
  24050    ;
  24051   "RTN","VPR P3I",92,0)
  24052   OI ; -- as sign Nursi ng orderab le items t o Treatmen ts
  24053   "RTN","VPR P3I",93,0)
  24054    N ORDG,OR X,ORI
  24055   "RTN","VPR P3I",94,0)
  24056    F ORDG="A CT","NURS"  D
  24057   "RTN","VPR P3I",95,0)
  24058    . S ORX=" " F  S ORX =$O(^ORD(1 01.43,"S." _ORDG,ORX) ) Q:ORX=""   D  ;OI n ame
  24059   "RTN","VPR P3I",96,0)
  24060    .. S ORI= 0 F  S ORI =$O(^ORD(1 01.43,"S." _ORDG,ORX, ORI)) Q:OR I<1  D SET ^ORDD43("N TX",ORI)
  24061   "RTN","VPR P3I",97,0)
  24062    Q
  24063   "RTN","VPR P3I",98,0)
  24064    ;
  24065   "RTN","VPR P3I",99,0)
  24066   OBJCNT ; - - create c ount index  for VPR O BJECT file
  24067   "RTN","VPR P3I",100,0 )
  24068    Q:$D(^VPR (560.11,"A CNT"))
  24069   "RTN","VPR P3I",101,0 )
  24070    N DIK,DA
  24071   "RTN","VPR P3I",102,0 )
  24072    S DIK="^V PR(560.11, "
  24073   "RTN","VPR P3I",103,0 )
  24074    S DIK(1)= ".03^ACNT"
  24075   "RTN","VPR P3I",104,0 )
  24076    D ENALL^D IK
  24077   "RTN","VPR P3I",105,0 )
  24078    Q
  24079   "RTN","VPR P3I",106,0 )
  24080   CREATEUS ;
  24081   "RTN","VPR P3I",107,0 )
  24082    N DIV,FDA ,IC,IEN,IE NS,NAME,SE R,VPRERR
  24083   "RTN","VPR P3I",108,0 )
  24084    ;do not c reate the  user if th e patch is  already i nstalled o r if the u ser is alr eady creat ed
  24085   "RTN","VPR P3I",109,0 )
  24086    I $$PATCH ^XPDUTL("V PR*1.0*3")  Q
  24087   "RTN","VPR P3I",110,0 )
  24088    D EN^DDIO L("Creatin g VPR Sync  User")
  24089   "RTN","VPR P3I",111,0 )
  24090    ;
  24091   "RTN","VPR P3I",112,0 )
  24092    S NAME="V PR,USER SY NC"
  24093   "RTN","VPR P3I",113,0 )
  24094    S IEN=$$C REATE^XUSA P(NAME,"", "VPR SYNCH RONIZATION  CONTEXT")
  24095   "RTN","VPR P3I",114,0 )
  24096    I IEN=0 D  EN^DDIOL( "User alre ady exists ") Q
  24097   "RTN","VPR P3I",115,0 )
  24098    I IEN<0 D  EN^DDIOL( "Cannot cr eate user" ) Q
  24099   "RTN","VPR P3I",116,0 )
  24100    S IENS="? "_IEN_","
  24101   "RTN","VPR P3I",117,0 )
  24102    S DIV=$$A SK(4) I DI V'>0 D EN^ DDIOL("A d ivision ne eds to be  selected." ) Q
  24103   "RTN","VPR P3I",118,0 )
  24104    S SER=$$A SK(49) I S ER'>0 D EN ^DDIOL("A  service ne eds to be  selected." ) Q
  24105   "RTN","VPR P3I",119,0 )
  24106    S FDA(200 ,IENS,.01) =NAME
  24107   "RTN","VPR P3I",120,0 )
  24108    S FDA(200 ,IENS,7.2) =1
  24109   "RTN","VPR P3I",121,0 )
  24110    S FDA(200 ,IENS,29)= $P(SER,U)
  24111   "RTN","VPR P3I",122,0 )
  24112    S FDA(200 ,IENS,200. 04)=1
  24113   "RTN","VPR P3I",123,0 )
  24114    S FDA(200 ,IENS,200. 1)=99999
  24115   "RTN","VPR P3I",124,0 )
  24116    ;S FDA(20 0.03,"?+2, "_IENS,.01 )="VPR SYN CHRONIZATI ON CONTEXT "
  24117   "RTN","VPR P3I",125,0 )
  24118    ;S FDA(20 0.03,"?+3, "_IENS,.01 )="VPR UI  CONTEXT"
  24119   "RTN","VPR P3I",126,0 )
  24120    S FDA(200 .02,"?+4," _IENS,.01) =$P(DIV,U)
  24121   "RTN","VPR P3I",127,0 )
  24122    S FDA(200 .02,"?+4," _IENS,1)=1
  24123   "RTN","VPR P3I",128,0 )
  24124    D UPDATE^ DIE("","FD A","","VPR ERR")
  24125   "RTN","VPR P3I",129,0 )
  24126    I $D(VPRE RR) D  Q
  24127   "RTN","VPR P3I",130,0 )
  24128    .D EN^DDI OL("Update  failed, U PDATE^DIE  returned t he followi ng error m essage.")
  24129   "RTN","VPR P3I",131,0 )
  24130    .S IC="VP RERR"
  24131   "RTN","VPR P3I",132,0 )
  24132    .F  S IC= $Q(@IC) Q: IC=""  W ! ,IC,"=",@I C
  24133   "RTN","VPR P3I",133,0 )
  24134    .D EN^DDI OL("Examin e the abov e error me ssage for  the reason .")
  24135   "RTN","VPR P3I",134,0 )
  24136    .H 2
  24137   "RTN","VPR P3I",135,0 )
  24138    D EN^DDIO L("Add ACC ESS/VERIFY  codes to  the "_NAME )
  24139   "RTN","VPR P3I",136,0 )
  24140    Q
  24141   "RTN","VPR P3I",137,0 )
  24142    ;
  24143   "RTN","VPR P3I",138,0 )
  24144   ASK(FILENU M) ;
  24145   "RTN","VPR P3I",139,0 )
  24146    N DIC,Y
  24147   "RTN","VPR P3I",140,0 )
  24148    S DIC=FIL ENUM,DIC(0 )="AEQMZ", DIC("A")=" Select "_$ S(FILENUM= 4:"divisio n: ",1:"se rvice/sect ion: ")
  24149   "RTN","VPR P3I",141,0 )
  24150    I FILENUM =4 S DIC(" S")="S DIN UM=X K:$S( $D(^XUSEC( ""XUMGR"", DUZ)):0,'$ $TF^XUAF4( X):1,1:0)  X,DINUM"
  24151   "RTN","VPR P3I",142,0 )
  24152    D ^DIC
  24153   "RTN","VPR P3I",143,0 )
  24154    Q Y
  24155   "RTN","VPR P3I",144,0 )
  24156    ;
  24157   "RTN","VPR P3I",145,0 )
  24158   TASKCONV ;
  24159   "RTN","VPR P3I",146,0 )
  24160    N COLL,I, IEN,NODE,P AT,TEMP,UI D,UPDATE,V PRY
  24161   "RTN","VPR P3I",147,0 )
  24162    K ^TMP($J ,"VPRY"),^ TMP($J,"VP RTEMP")
  24163   "RTN","VPR P3I",148,0 )
  24164    S VPRY=$N A(^TMP($J, "VPRY")),T EMP=$NA(^T MP($J,"VPR TEMP"))
  24165   "RTN","VPR P3I",149,0 )
  24166    S PAT=0 F   S PAT=$O (^VPR(560. 1,"C",PAT) ) Q:PAT'>0   D
  24167   "RTN","VPR P3I",150,0 )
  24168    .S IEN=0  F  S IEN=$ O(^VPR(560 .1,"C",PAT ,"task",IE N)) Q:IEN' >0  D
  24169   "RTN","VPR P3I",151,0 )
  24170    ..S NODE= $G(^VPR(56 0.1,IEN,0) )
  24171   "RTN","VPR P3I",152,0 )
  24172    ..S UID=$ P(NODE,U)  I UID="" Q
  24173   "RTN","VPR P3I",153,0 )
  24174    ..S UPDAT E=0
  24175   "RTN","VPR P3I",154,0 )
  24176    ..S I=0 F   S I=$O(^ VPR(560.1, IEN,1,I))  Q:I<1  S X =$G(^(I,0) ),VPRY(I)= X
  24177   "RTN","VPR P3I",155,0 )
  24178    ..D DECOD E^VPRJSON( "VPRY","TE MP","ERROR ")
  24179   "RTN","VPR P3I",156,0 )
  24180    ..I $D(ER ROR) D EN^ DDIOL("Err or in deco ding JSON  Object") Q
  24181   "RTN","VPR P3I",157,0 )
  24182    ..K VPRY, ^TMP($J,"V PRY")
  24183   "RTN","VPR P3I",158,0 )
  24184    ..I $G(@T EMP@("assi gnToCode") )'="" S @T EMP@("crea tedByCode" )=@TEMP@(" assignToCo de"),UPDAT E=1 K @TEM P@("assign ToCode")
  24185   "RTN","VPR P3I",159,0 )
  24186    ..I $G(@T EMP@("assi gnToName") )'="" S @T EMP@("crea tedByName" )=@TEMP@(" assignToNa me"),UPDAT E=1 K @TEM P@("assign ToName")
  24187   "RTN","VPR P3I",160,0 )
  24188    ..I $G(@T EMP@("owne rName"))'= "" S UPDAT E=1 K @TEM P@("ownerN ame")
  24189   "RTN","VPR P3I",161,0 )
  24190    ..I $G(@T EMP@("owne rCode"))'= "" S UPDAT E=1 K @TEM P@("ownerC ode")
  24191   "RTN","VPR P3I",162,0 )
  24192    ..I UPDAT E=0 Q
  24193   "RTN","VPR P3I",163,0 )
  24194    ..;
  24195   "RTN","VPR P3I",164,0 )
  24196    ..S VPRY= $NA(^TMP($ J,"VPRY"))
  24197   "RTN","VPR P3I",165,0 )
  24198    ..D ENCOD E^VPRJSON( "TEMP","VP RY","ERROR ")
  24199   "RTN","VPR P3I",166,0 )
  24200    ..I $D(ER ROR) D EN^ DDIOL("Err or in enco ding JSON  Object") Q
  24201   "RTN","VPR P3I",167,0 )
  24202    ..D EN^DD IOL("Updat ing task u id: "_UID)
  24203   "RTN","VPR P3I",168,0 )
  24204    ..D PUT^V PRDJ1(.VPR ,PAT,"task ",.VPRY)
  24205   "RTN","VPR P3I",169,0 )
  24206    K ^TMP($J ,"VPRY"),^ TMP($J,"VP RTEMP")
  24207   "RTN","VPR P3I",170,0 )
  24208    Q
  24209   "RTN","VPR P3I",171,0 )
  24210   ADDRSRC ;  Add resour ce device
  24211   "RTN","VPR P3I",172,0 )
  24212    N RNAME,R DESC,RSLOT ,RTYPE,RIE N
  24213   "RTN","VPR P3I",173,0 )
  24214    S RNAME=" VPR EXTRAC T RESOURCE "
  24215   "RTN","VPR P3I",174,0 )
  24216    S RDESC=" Controls t he number  of VPR ext ract jobs  that run s imultaneou sly."
  24217   "RTN","VPR P3I",175,0 )
  24218    S RSLOT=1 0
  24219   "RTN","VPR P3I",176,0 )
  24220    S RTYPE=" P-OTHER"
  24221   "RTN","VPR P3I",177,0 )
  24222    S RIEN=$$ RES^XUDHSE T(RNAME,RN AME,RSLOT, RDESC,RTYP E)
  24223   "RTN","VPR P3I",178,0 )
  24224    Q
  24225   "RTN","VPR P3I",179,0 )
  24226   PARPID ; L oop thru V PR PARAMET ERS and sw itch ICN t o qualifie d DFN
  24227   "RTN","VPR P3I",180,0 )
  24228    N PAR,ENT ,UID,VPRWP ,VPRERR,I, VPRSYS
  24229   "RTN","VPR P3I",181,0 )
  24230    S VPRSYS= $$GET^XPAR ("SYS","VP R SYSTEM N AME")
  24231   "RTN","VPR P3I",182,0 )
  24232    S PAR=$O( ^XTV(8989. 51,"B","VP R PARAMETE RS","")) Q :PAR'>0
  24233   "RTN","VPR P3I",183,0 )
  24234    S ENT=""  F  S ENT=$ O(^XTV(898 9.5,"AC",P AR,ENT)) Q :ENT=""  D
  24235   "RTN","VPR P3I",184,0 )
  24236    . S UID=" " F  S UID =$O(^XTV(8 989.5,"AC" ,PAR,ENT,U ID)) Q:UID =""  D  ;I NST=UID
  24237   "RTN","VPR P3I",185,0 )
  24238    . . I $P( UID,":",6, 7)'="VPR U SER PREF:0 " Q
  24239   "RTN","VPR P3I",186,0 )
  24240    . . N VPR WP,VPRERR, JSON,OBJ,E RR,DFN,RSL T
  24241   "RTN","VPR P3I",187,0 )
  24242    . . D GET WP^XPAR(.V PRWP,ENT,P AR,UID,.VP RERR)
  24243   "RTN","VPR P3I",188,0 )
  24244    . . I +VP RERR D WRE RR(UID,$P( VPRERR,U,2 ,99)) Q
  24245   "RTN","VPR P3I",189,0 )
  24246    . . I $D( VPRWP)<10  Q                           ; no  JSON foun d
  24247   "RTN","VPR P3I",190,0 )
  24248    . . S I=0  F  S I=$O (VPRWP(I))  Q:'I  S J SON(I)=VPR WP(I,0)
  24249   "RTN","VPR P3I",191,0 )
  24250    . . D DEC ODE^VPRJSO N("JSON"," OBJ","ERR" )
  24251   "RTN","VPR P3I",192,0 )
  24252    . . I $D( ERR) D WRE RR(UID,"Er ror decodi ng JSON")  Q
  24253   "RTN","VPR P3I",193,0 )
  24254    . . I '$L ($G(OBJ("c pe.context .patient") )) Q  ; no thing ther e
  24255   "RTN","VPR P3I",194,0 )
  24256    . . I OBJ ("cpe.cont ext.patien t")[";" Q        ; al ready DFN
  24257   "RTN","VPR P3I",195,0 )
  24258    . . S DFN =$$GETDFN^ MPIF001(OB J("cpe.con text.patie nt"))
  24259   "RTN","VPR P3I",196,0 )
  24260    . . I DFN <1 D WRERR (UID,"Erro r converti ng ICN: "_ $P(DFN,U,2 )) Q
  24261   "RTN","VPR P3I",197,0 )
  24262    . . S OBJ ("cpe.cont ext.patien t")=VPRSYS _";"_DFN
  24263   "RTN","VPR P3I",198,0 )
  24264    . . K JSO N
  24265   "RTN","VPR P3I",199,0 )
  24266    . . D ENC ODE^VPRJSO N("OBJ","J SON","ERR" )
  24267   "RTN","VPR P3I",200,0 )
  24268    . . I $D( ERR) D WRE RR(UID,"Er ror encodi ng JSON")  Q
  24269   "RTN","VPR P3I",201,0 )
  24270    . . D PUT BYUID^VPRP ARAM(.RSLT ,UID,.JSON )
  24271   "RTN","VPR P3I",202,0 )
  24272    Q
  24273   "RTN","VPR P3I",203,0 )
  24274   WRERR(UID, MSG) ; Wri te out err or (from p ost-init i n KIDS bui ld)
  24275   "RTN","VPR P3I",204,0 )
  24276    D MES^XPD UTL("Error : "_MSG_"  for UID "_ UID)
  24277   "RTN","VPR P3I",205,0 )
  24278    Q
  24279   "RTN","VPR PANEL")
  24280   0^11^B9307 129
  24281   "RTN","VPR PANEL",1,0 )
  24282   VPRPANEL ; SLC/GRR --  Reminder  List proce ssing
  24283   "RTN","VPR PANEL",2,0 )
  24284    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  24285   "RTN","VPR PANEL",3,0 )
  24286    ;
  24287   "RTN","VPR PANEL",4,0 )
  24288    ; Externa l Referenc es           DBIA#
  24289   "RTN","VPR PANEL",5,0 )
  24290    ; ------- ---------- --           -----
  24291   "RTN","VPR PANEL",6,0 )
  24292    ;
  24293   "RTN","VPR PANEL",7,0 )
  24294    ; ------- ----- Get  Panel(s) f rom VistA  ---------- --
  24295   "RTN","VPR PANEL",8,0 )
  24296    ;
  24297   "RTN","VPR PANEL",9,0 )
  24298   EN(VPR) ;  -- find Pa nels to up date
  24299   "RTN","VPR PANEL",10, 0)
  24300    K ^TMP($J ,"VPRPANEL ")
  24301   "RTN","VPR PANEL",11, 0)
  24302    N VPRPAN, VPRPAT,VPR I
  24303   "RTN","VPR PANEL",12, 0)
  24304    S VPR=$NA (^TMP($J," VPR")),VPR C=0,VPRT=0
  24305   "RTN","VPR PANEL",13, 0)
  24306    F  S VPRC =$O(^VPROS TER(VPRC))  Q:VPRC'>0   D
  24307   "RTN","VPR PANEL",14, 0)
  24308    . S VPRT= VPRT+1
  24309   "RTN","VPR PANEL",15, 0)
  24310    . S VPRPA N(VPRC)=^V PROSTER(VP RC,0) D
  24311   "RTN","VPR PANEL",16, 0)
  24312    . N LIEN, PLNAME S L IEN=+$P(VP RPAN(VPRC) ,"^",2),PL NAME=$P(VP RPAN(VPRC) ,U,1)
  24313   "RTN","VPR PANEL",17, 0)
  24314    . ;agp ne ed to dete rmine what  secure an d over sho uld be set  to
  24315   "RTN","VPR PANEL",18, 0)
  24316    . S SECUR E=0,OVER=1
  24317   "RTN","VPR PANEL",19, 0)
  24318    . D RUNLI ST(.VPRPAN ,LIEN,PLNA ME,SECURE, OVER)
  24319   "RTN","VPR PANEL",20, 0)
  24320   CREATE ; - - create p anel(s) in  XML
  24321   "RTN","VPR PANEL",21, 0)
  24322    N VPRVER  S VPRVER=" <results v ersion='"_ $P($T(VPRP ANEL+1),"; ",3)_"'>"
  24323   "RTN","VPR PANEL",22, 0)
  24324    N VPRTTXT  S VPRTTXT ="<panels  total='"_V PRT_"'>"
  24325   "RTN","VPR PANEL",23, 0)
  24326    D ADD(VPR VER),ADD(V PRTTXT)
  24327   "RTN","VPR PANEL",24, 0)
  24328    D PANEL
  24329   "RTN","VPR PANEL",25, 0)
  24330    S TEXT="< /results>"  D ADD(TEX T)
  24331   "RTN","VPR PANEL",26, 0)
  24332    Q
  24333   "RTN","VPR PANEL",27, 0)
  24334    ;
  24335   "RTN","VPR PANEL",28, 0)
  24336   PANEL ;--  create pan el XML
  24337   "RTN","VPR PANEL",29, 0)
  24338    S VPRC=0  F  S VPRC= $O(VPRPAN( VPRC)) Q:V PRC'>0  D
  24339   "RTN","VPR PANEL",30, 0)
  24340    .D ADD("< panel>")
  24341   "RTN","VPR PANEL",31, 0)
  24342    .N TEXT S  TEXT="<pa nel name=' "_$P(VPRPA N(VPRC),"^ ",2)_"' /> " D ADD(TE XT)
  24343   "RTN","VPR PANEL",32, 0)
  24344    .S TEXT=" <panelStri ng code='" _$P(VPRPAN (VPRC),"^" )_"' />" D  ADD(TEXT)
  24345   "RTN","VPR PANEL",33, 0)
  24346    .D PATS
  24347   "RTN","VPR PANEL",34, 0)
  24348    .S TEXT=" </panel>"  D ADD(TEXT )
  24349   "RTN","VPR PANEL",35, 0)
  24350    S TEXT="< /panels>"  D ADD(TEXT )
  24351   "RTN","VPR PANEL",36, 0)
  24352    Q
  24353   "RTN","VPR PANEL",37, 0)
  24354    ;
  24355   "RTN","VPR PANEL",38, 0)
  24356   CREATEPL(P LNAME,SECU RE,OVER) ;
  24357   "RTN","VPR PANEL",39, 0)
  24358    N FDA,IEN S,NAME,NUM ,RESULT,UN IQUE
  24359   "RTN","VPR PANEL",40, 0)
  24360    S (NUM,RE SULT,UNIQU E)=0
  24361   "RTN","VPR PANEL",41, 0)
  24362    ;if overw rite check  to see if  the list  exist
  24363   "RTN","VPR PANEL",42, 0)
  24364    I OVER=1  S RESULT=$ O(^PXRMXP( 810.5,"B", PLNAME,"") )
  24365   "RTN","VPR PANEL",43, 0)
  24366    I RESULT> 0 Q RESULT
  24367   "RTN","VPR PANEL",44, 0)
  24368    S NAME=PL NAME
  24369   "RTN","VPR PANEL",45, 0)
  24370    ;if not o verwrite f ind unique  name
  24371   "RTN","VPR PANEL",46, 0)
  24372    I OVER=0  D
  24373   "RTN","VPR PANEL",47, 0)
  24374    .I $D(^PX RMXP(810.5 ,"B",NAME) )=0 Q
  24375   "RTN","VPR PANEL",48, 0)
  24376    .F  Q:UNI QUE=1  D
  24377   "RTN","VPR PANEL",49, 0)
  24378    ..S NUM=N UM+1
  24379   "RTN","VPR PANEL",50, 0)
  24380    ..S NAME= PLNAME_" ( "_NUM_")"
  24381   "RTN","VPR PANEL",51, 0)
  24382    ..I $D(^P XRMXP(810. 5,"B",NAME ))=0 S UNI QUE=1
  24383   "RTN","VPR PANEL",52, 0)
  24384    ;create s tub in 810 .5
  24385   "RTN","VPR PANEL",53, 0)
  24386    S IENS="+ 1,"
  24387   "RTN","VPR PANEL",54, 0)
  24388    S FDA(810 .5,IENS,.0 1)=NAME
  24389   "RTN","VPR PANEL",55, 0)
  24390    S FDA(810 .5,IENS,10 0)="L"
  24391   "RTN","VPR PANEL",56, 0)
  24392    S FDA(810 .5,IENS,.0 7)=DUZ
  24393   "RTN","VPR PANEL",57, 0)
  24394    S FDA(810 .5,IENS,.0 8)=$S(SECU RE=0:"PUB" ,1:"PVT")
  24395   "RTN","VPR PANEL",58, 0)
  24396    D UPDATE^ DIE("","FD A","","MSG ")
  24397   "RTN","VPR PANEL",59, 0)
  24398    ;if error  display m essage and  quit
  24399   "RTN","VPR PANEL",60, 0)
  24400    I $D(MSG)  D AWRITE^ PXRMUTIL(" MSG") Q 0
  24401   "RTN","VPR PANEL",61, 0)
  24402    S RESULT= $O(^PXRMXP (810.5,"B" ,NAME,""))
  24403   "RTN","VPR PANEL",62, 0)
  24404    Q RESULT
  24405   "RTN","VPR PANEL",63, 0)
  24406    ;
  24407   "RTN","VPR PANEL",64, 0)
  24408   RUNLIST(VP RPAN,LIEN, PLNAME,SEC URE,OVER)  ;
  24409   "RTN","VPR PANEL",65, 0)
  24410    N PLIEN
  24411   "RTN","VPR PANEL",66, 0)
  24412    S PLIEN=$ $CREATEPL( PLNAME,SEC URE,OVER)
  24413   "RTN","VPR PANEL",67, 0)
  24414    S PATCREA T=$S(SECUR E=1:"Y",1: 0),PLISTPU G=1
  24415   "RTN","VPR PANEL",68, 0)
  24416    I PLIEN=0  Q
  24417   "RTN","VPR PANEL",69, 0)
  24418    D RUN^PXR MLCR(LIEN, PLIEN,"PXR MRULE",DT, DT,0,0)
  24419   "RTN","VPR PANEL",70, 0)
  24420    N VPRPAT  S VPRPAT=0
  24421   "RTN","VPR PANEL",71, 0)
  24422    F  S VPRP AT=$O(^PXR MXP(810.5, PLIEN,30,V PRPAT)) Q: VPRPAT'>0   S VPRPAN( VPRC,VPRPA T)=$P($G(^ PXRMXP(810 .5,PLIEN,3 0,VPRPAT,0 )),"^",1)
  24423   "RTN","VPR PANEL",72, 0)
  24424    Q
  24425   "RTN","VPR PANEL",73, 0)
  24426    ;
  24427   "RTN","VPR PANEL",74, 0)
  24428   PATS ; --  create pat ient XML
  24429   "RTN","VPR PANEL",75, 0)
  24430    S TEXT="< patients>"  D ADD(TEX T)
  24431   "RTN","VPR PANEL",76, 0)
  24432    S VPRPAT= 0 F  S VPR PAT=$O(VPR PAN(VPRC,V PRPAT)) D   Q:VPRPAT' >0
  24433   "RTN","VPR PANEL",77, 0)
  24434    .I VPRPAT '>0 S TEXT ="</patien ts>" D ADD (TEXT) Q
  24435   "RTN","VPR PANEL",78, 0)
  24436    .S TEXT=" <patient c ode='"_VPR PAN(VPRC,V PRPAT)_"'  />" D ADD( TEXT)
  24437   "RTN","VPR PANEL",79, 0)
  24438    ;
  24439   "RTN","VPR PANEL",80, 0)
  24440    ;
  24441   "RTN","VPR PANEL",81, 0)
  24442   ADD(X) ; - - Add a li ne @VPR@(n )=X
  24443   "RTN","VPR PANEL",82, 0)
  24444    S VPRI=$G (VPRI)+1
  24445   "RTN","VPR PANEL",83, 0)
  24446    S @VPR@(V PRI)=X
  24447   "RTN","VPR PANEL",84, 0)
  24448    Q
  24449   "RTN","VPR PANEL",85, 0)
  24450    ;
  24451   "RTN","VPR PANEL",86, 0)
  24452   NITELY ; - - Nightly  run to upd ate all Pa nels
  24453   "RTN","VPR PANEL",87, 0)
  24454    ; 
  24455   "RTN","VPR PARAM")
  24456   0^59^B1543 6113
  24457   "RTN","VPR PARAM",1,0 )
  24458   VPRPARAM ;  SLC/AGP -  Parameter  routine.  ; 8/16/12  7:09pm
  24459   "RTN","VPR PARAM",2,0 )
  24460    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  24461   "RTN","VPR PARAM",3,0 )
  24462    Q
  24463   "RTN","VPR PARAM",4,0 )
  24464    ;
  24465   "RTN","VPR PARAM",5,0 )
  24466    ;
  24467   "RTN","VPR PARAM",6,0 )
  24468   BLDENT(UID ,ENTITY) ;
  24469   "RTN","VPR PARAM",7,0 )
  24470    ;urn:va:p aram:F484: 1120:VPR U SER PREF
  24471   "RTN","VPR PARAM",8,0 )
  24472    ;urn:va:p aram:F484: 1120:VPR R OSTER PREF :13
  24473   "RTN","VPR PARAM",9,0 )
  24474    ;urn:va:p aram:F484: SYS:VPR US ER PREF
  24475   "RTN","VPR PARAM",10, 0)
  24476    S ENTITY( "uid")=UID
  24477   "RTN","VPR PARAM",11, 0)
  24478    I +$P(UID ,":",5)>0  D  Q
  24479   "RTN","VPR PARAM",12, 0)
  24480    .S ENTITY ("entity") ="USR"
  24481   "RTN","VPR PARAM",13, 0)
  24482    .S ENTITY ("entityId ")=$P(UID, ":",5)
  24483   "RTN","VPR PARAM",14, 0)
  24484    S ENTITY( "entity")= "SYS"
  24485   "RTN","VPR PARAM",15, 0)
  24486    Q
  24487   "RTN","VPR PARAM",16, 0)
  24488    ;
  24489   "RTN","VPR PARAM",17, 0)
  24490   BUILDUID(V ALUES,TYPE ,ID) ;
  24491   "RTN","VPR PARAM",18, 0)
  24492    N DOMAIN
  24493   "RTN","VPR PARAM",19, 0)
  24494    S DOMAIN= $$BASE^XLF UTL($$CRC1 6^XLFCRC($ $KSP^XUPAR AM("WHERE" )),10,16)
  24495   "RTN","VPR PARAM",20, 0)
  24496    S VALUES( "uid")="ur n:va:"_TYP E_":"_DOMA IN_":"_ID
  24497   "RTN","VPR PARAM",21, 0)
  24498    Q
  24499   "RTN","VPR PARAM",22, 0)
  24500    ;
  24501   "RTN","VPR PARAM",23, 0)
  24502   DELPARAM(R ESULT,UID)  ;
  24503   "RTN","VPR PARAM",24, 0)
  24504    N ARRAY,E NT,ENTITY, ENTVALUE,E RR,STR,VPR ERR
  24505   "RTN","VPR PARAM",25, 0)
  24506    D BLDENT( UID,.ARRAY )
  24507   "RTN","VPR PARAM",26, 0)
  24508    ;delete o ld paramet er
  24509   "RTN","VPR PARAM",27, 0)
  24510    S ENTITY= ARRAY("ent ity")
  24511   "RTN","VPR PARAM",28, 0)
  24512    S ENTVALU E=ARRAY("e ntityId")
  24513   "RTN","VPR PARAM",29, 0)
  24514    S ENT=$S( $G(ENTVALU E)>0:ENTIT Y_".`"_ENT VALUE,1:EN TITY)
  24515   "RTN","VPR PARAM",30, 0)
  24516    I $G(ARRA Y("uid"))= "" Q
  24517   "RTN","VPR PARAM",31, 0)
  24518    I $G(ENT) ="" Q
  24519   "RTN","VPR PARAM",32, 0)
  24520    D DEL^XPA R(ENT,"VPR  PARAMETER S",ARRAY(" uid"),.VPR ERR)
  24521   "RTN","VPR PARAM",33, 0)
  24522    Q
  24523   "RTN","VPR PARAM",34, 0)
  24524    ;
  24525   "RTN","VPR PARAM",35, 0)
  24526   GETALPAR(J SONRES,ENT ITY,ENTVAL UE,RETVALU E) ;
  24527   "RTN","VPR PARAM",36, 0)
  24528    N CNT,DEC ODE,ENT,GE TVAL,INST, PARAM,RESU LT,VPRERR, VPRLIST
  24529   "RTN","VPR PARAM",37, 0)
  24530    S ENT=$S( $G(ENTVALU E)'="":ENT ITY_".`"_E NTVALUE,1: ENTITY)
  24531   "RTN","VPR PARAM",38, 0)
  24532    D GETLST^ XPAR(.VPRL IST,ENT,"V PR PARAMET ERS","I")
  24533   "RTN","VPR PARAM",39, 0)
  24534    I VPRLIST =0 Q
  24535   "RTN","VPR PARAM",40, 0)
  24536    S GETVAL= $S(RETVALU E="true":1 ,1:0)
  24537   "RTN","VPR PARAM",41, 0)
  24538    I GETVAL= 0 D   Q
  24539   "RTN","VPR PARAM",42, 0)
  24540    .S CNT=0, INST="" F   S INST=$O (VPRLIST(I NST)) Q:IN ST=""  S J SONRES(CNT )=INST,CNT =CNT+1
  24541   "RTN","VPR PARAM",43, 0)
  24542    S CNT=0,I NST="" F   S INST=$O( VPRLIST(IN ST)) Q:INS T=""  D
  24543   "RTN","VPR PARAM",44, 0)
  24544    .S CNT=CN T+1
  24545   "RTN","VPR PARAM",45, 0)
  24546    .S RESULT ("params", CNT,"uid") =INST
  24547   "RTN","VPR PARAM",46, 0)
  24548    .D GETPAR AM(.PARAM, "VPR PARAM ETERS",ENT ITY,ENTVAL UE,INST)
  24549   "RTN","VPR PARAM",47, 0)
  24550    .I '$D(PA RAM) Q
  24551   "RTN","VPR PARAM",48, 0)
  24552    .M RESULT ("params", CNT,"value ",":")=PAR AM
  24553   "RTN","VPR PARAM",49, 0)
  24554    .K PARAM
  24555   "RTN","VPR PARAM",50, 0)
  24556    I '$D(RES ULT) Q ""
  24557   "RTN","VPR PARAM",51, 0)
  24558    S RESULT( "success") ="true"
  24559   "RTN","VPR PARAM",52, 0)
  24560    D ENCODE^ VPRJSON("R ESULT","JS ONRES","VP RERR")
  24561   "RTN","VPR PARAM",53, 0)
  24562    I $D(VPRE RR) K JSON RES S TXT( 1)="Proble m encoding  results t o json for mat." D SE TERROR(.RE SULT,.VPRE RR,.TXT,.J SONRES) Q
  24563   "RTN","VPR PARAM",54, 0)
  24564    Q
  24565   "RTN","VPR PARAM",55, 0)
  24566    ;
  24567   "RTN","VPR PARAM",56, 0)
  24568   GETPARAM(R ESULT,NAME ,ENTITY,EN TVALUE,INS T) ; Get v alue for a  param
  24569   "RTN","VPR PARAM",57, 0)
  24570    N CNT,ENT ,FORMAT,IE N,VPRPAR,V PRERR
  24571   "RTN","VPR PARAM",58, 0)
  24572    ;S IEN=$O (^XTV(8989 .51,"B",NA ME,"")) Q: IEN'>0
  24573   "RTN","VPR PARAM",59, 0)
  24574    S FORMAT= "I"
  24575   "RTN","VPR PARAM",60, 0)
  24576    ;D BLDLST ^XPAREDIT( .VPRPAR,IE N
  24577   "RTN","VPR PARAM",61, 0)
  24578    S ENT=$S( $G(ENTVALU E)'="":ENT ITY_".`"_E NTVALUE,1: ENTITY)
  24579   "RTN","VPR PARAM",62, 0)
  24580    D GETWP^X PAR(.VPRAR ,ENT,NAME, INST,.VPRE RR)
  24581   "RTN","VPR PARAM",63, 0)
  24582    S CNT=0 F   S CNT=$O (VPRAR(CNT )) Q:CNT'> 0  D
  24583   "RTN","VPR PARAM",64, 0)
  24584    .S RESULT (CNT)=VPRA R(CNT,0)
  24585   "RTN","VPR PARAM",65, 0)
  24586    Q
  24587   "RTN","VPR PARAM",66, 0)
  24588    ;
  24589   "RTN","VPR PARAM",67, 0)
  24590   GETBYUID(R ESULT,UID)  ;
  24591   "RTN","VPR PARAM",68, 0)
  24592    N ENTITY
  24593   "RTN","VPR PARAM",69, 0)
  24594    D BLDENT( UID,.ENTIT Y)
  24595   "RTN","VPR PARAM",70, 0)
  24596    D GETPARA M(.RESULT, "VPR PARAM ETERS",$G( ENTITY("en tity")),$G (ENTITY("e ntityId")) ,$G(ENTITY ("uid")))
  24597   "RTN","VPR PARAM",71, 0)
  24598    ;I $D(RES ULT)<10 S  RESULT(0)= "{}"
  24599   "RTN","VPR PARAM",72, 0)
  24600    Q
  24601   "RTN","VPR PARAM",73, 0)
  24602    ;
  24603   "RTN","VPR PARAM",74, 0)
  24604   PARSEJSN(V ALUE,ARRAY ,ERR) ;
  24605   "RTN","VPR PARAM",75, 0)
  24606    N ERROR,J SON,TXT
  24607   "RTN","VPR PARAM",76, 0)
  24608    D DECODE^ VPRJSON("V ALUE","ARR AY","ERROR ")
  24609   "RTN","VPR PARAM",77, 0)
  24610    I $D(ERR)  K ARRAY S  TXT(1)="P roblem dec oding json  value." D  SETERROR( .VALUE,.ER ROR,.TXT,. ERR) Q 0
  24611   "RTN","VPR PARAM",78, 0)
  24612    Q 1
  24613   "RTN","VPR PARAM",79, 0)
  24614    ;
  24615   "RTN","VPR PARAM",80, 0)
  24616   PUTPARAM(R ESULT,VALU E,ENTARR)  ;
  24617   "RTN","VPR PARAM",81, 0)
  24618    N CNT,ENT ,ENTITY,EN TVALUE,ERR ,STR,VPRER R,X
  24619   "RTN","VPR PARAM",82, 0)
  24620    I $D(ENTA RR)<10 I $ $PARSEJSN( .VALUE,.EN TARR,.ERR) =0 M RESUL T=ERR Q
  24621   "RTN","VPR PARAM",83, 0)
  24622    ;delete o ld paramet er
  24623   "RTN","VPR PARAM",84, 0)
  24624    S ENTITY= ENTARR("en tity")
  24625   "RTN","VPR PARAM",85, 0)
  24626    S ENTVALU E=ENTARR(" entityId")
  24627   "RTN","VPR PARAM",86, 0)
  24628    S ENT=$S( $G(ENTVALU E)>0:ENTIT Y_".`"_ENT VALUE,1:EN TITY)
  24629   "RTN","VPR PARAM",87, 0)
  24630    D DEL^XPA R(ENT,"VPR  PARAMETER S",ENTARR( "uid"),.VP RERR)
  24631   "RTN","VPR PARAM",88, 0)
  24632    S CNT=$O( VALUE(""), -1) I CNT= "" S STR(1 ,0)=VALUE
  24633   "RTN","VPR PARAM",89, 0)
  24634    I CNT>0 F  X=0:1:CNT  S STR(X+1 ,0)=VALUE( X)
  24635   "RTN","VPR PARAM",90, 0)
  24636    D PUT^XPA R(ENT,"VPR  PARAMETER S",ENTARR( "uid"),.ST R,.VPRERR)
  24637   "RTN","VPR PARAM",91, 0)
  24638    S RESULT( 0)="{""suc cess"":""t rue""}"
  24639   "RTN","VPR PARAM",92, 0)
  24640    Q
  24641   "RTN","VPR PARAM",93, 0)
  24642    ;
  24643   "RTN","VPR PARAM",94, 0)
  24644   PUTBYUID(R ESULT,UID, VALUE) ;
  24645   "RTN","VPR PARAM",95, 0)
  24646    N ENTITY
  24647   "RTN","VPR PARAM",96, 0)
  24648    D BLDENT( UID,.ENTIT Y)
  24649   "RTN","VPR PARAM",97, 0)
  24650    D PUTPARA M(.RESULT, .VALUE,.EN TITY)
  24651   "RTN","VPR PARAM",98, 0)
  24652    Q
  24653   "RTN","VPR PARAM",99, 0)
  24654    ;
  24655   "RTN","VPR PARAM",100 ,0)
  24656   SETERROR(I NPDATA,ERR ORMSG,TXT, OUTPUT) ;
  24657   "RTN","VPR PARAM",101 ,0)
  24658    N ERRARR
  24659   "RTN","VPR PARAM",102 ,0)
  24660    D SETERRO R^VPRUTILS (.ERRARR,. ERRORMSG,. TXT,.INPDA TA)
  24661   "RTN","VPR PARAM",103 ,0)
  24662    D ENCODE^ VPRJSON("E RRARR","OU TPUT","ERR OR")
  24663   "RTN","VPR PARAM",104 ,0)
  24664    Q
  24665   "RTN","VPR PATS")
  24666   0^3^B44568 818
  24667   "RTN","VPR PATS",1,0)
  24668   VPRPATS ;S LC/MKB --  Patient Ma nagement U tilities
  24669   "RTN","VPR PATS",2,0)
  24670    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  24671   "RTN","VPR PATS",3,0)
  24672    ;
  24673   "RTN","VPR PATS",4,0)
  24674    ; Externa l Referenc es           DBIA#
  24675   "RTN","VPR PATS",5,0)
  24676    ; ------- ---------- --           -----
  24677   "RTN","VPR PATS",6,0)
  24678    ; ^DGS(41 .1                       3796
  24679   "RTN","VPR PATS",7,0)
  24680    ; ^DPT                            10035
  24681   "RTN","VPR PATS",8,0)
  24682    ; ^OR(100 .21
  24683   "RTN","VPR PATS",9,0)
  24684    ; ^PXRMXP (810.5
  24685   "RTN","VPR PATS",10,0 )
  24686    ; ^SC                             10040
  24687   "RTN","VPR PATS",11,0 )
  24688    ; ^SCTM(4 04.51                   +2936? > >or use FI ND^DIC?
  24689   "RTN","VPR PATS",12,0 )
  24690    ; DICN                            10009
  24691   "RTN","VPR PATS",13,0 )
  24692    ; MPIF001                          2701
  24693   "RTN","VPR PATS",14,0 )
  24694    ; SCAPMC                           1916
  24695   "RTN","VPR PATS",15,0 )
  24696    ; SDAMA30 1                        4433
  24697   "RTN","VPR PATS",16,0 )
  24698    ; XLFDT                           10103
  24699   "RTN","VPR PATS",17,0 )
  24700    ; XPAR                             2263
  24701   "RTN","VPR PATS",18,0 )
  24702    ; XUAF4                            2171
  24703   "RTN","VPR PATS",19,0 )
  24704    ;
  24705   "RTN","VPR PATS",20,0 )
  24706   APPT ; --  Return pat ients w/ap pointments  tomorrow
  24707   "RTN","VPR PATS",21,0 )
  24708    ; OPT = V PR APPOINT MENTS
  24709   "RTN","VPR PATS",22,0 )
  24710    N NOW,NOW 1,VPRX,VPR L,VPRN,DFN ,DA,TOKEN, NEW,X
  24711   "RTN","VPR PATS",23,0 )
  24712    S NOW=$$N OW^XLFDT,N OW1=$$FMAD D^XLFDT(NO W,1)
  24713   "RTN","VPR PATS",24,0 )
  24714    S VPRX(1) =NOW_";"_N OW1 ;next  24hours
  24715   "RTN","VPR PATS",25,0 )
  24716    S VPRX("F LDS")=1,VP RX("SORT") ="P",VPRX( 3)="R;I;NT "
  24717   "RTN","VPR PATS",26,0 )
  24718    ; ck para meter for  desired lo cation(s):  VPRX(2)=" loc1;loc2; ...;loc#"
  24719   "RTN","VPR PATS",27,0 )
  24720    D GETLST^ XPAR(.VPRL ,"ALL","VP R LOCATION S") I +$G( VPRL) D
  24721   "RTN","VPR PATS",28,0 )
  24722    . S X=+$G (VPRL(1)), VPRX(2)=$S ($D(^SC(X, 0)):X,1:"" )
  24723   "RTN","VPR PATS",29,0 )
  24724    . F I=2:1 :+VPRL S X =+$G(VPRL( I)) S:$D(^ SC(X,0)) V PRX(2)=VPR X(2)_";"_X
  24725   "RTN","VPR PATS",30,0 )
  24726    S VPRN=$$ SDAPI^SDAM A301(.VPRX ) Q:VPRN<1
  24727   "RTN","VPR PATS",31,0 )
  24728    S DFN=0 F   S DFN=$O (^TMP($J," SDAMA301", DFN)) Q:DF N<1  D
  24729   "RTN","VPR PATS",32,0 )
  24730    . S DA=0  F  S DA=$O (^VPR(560, DA)) Q:DA< 1  I $P($G (^(DA,0)), U,2) D
  24731   "RTN","VPR PATS",33,0 )
  24732    .. Q:$D(^ VPR(560,"A DFN",DFN,D A))  ;alre ady subscr ibed
  24733   "RTN","VPR PATS",34,0 )
  24734    .. S TOKE N=DA_"~"_N OW,NEW(TOK EN)=""
  24735   "RTN","VPR PATS",35,0 )
  24736    .. S ^XTM P("VPRX",T OKEN,DFN)= ""
  24737   "RTN","VPR PATS",36,0 )
  24738    I $D(NEW)  D SEND^VP RHTTP(.NEW ) ;send po ke to each  URL with  list TOKEN
  24739   "RTN","VPR PATS",37,0 )
  24740    Q
  24741   "RTN","VPR PATS",38,0 )
  24742    ;
  24743   "RTN","VPR PATS",39,0 )
  24744   ADM(DFN) ;  -- Return  new inpat ient [from  DGPM^VPRE VNT]
  24745   "RTN","VPR PATS",40,0 )
  24746    N NOW,DA, TOKEN,NEW
  24747   "RTN","VPR PATS",41,0 )
  24748    S NOW=$$N OW^XLFDT,D FN=+$G(DFN )
  24749   "RTN","VPR PATS",42,0 )
  24750    S DA=0 F   S DA=$O(^ VPR(560,DA )) Q:DA<1   I $P($G(^ (DA,0)),U, 3) D
  24751   "RTN","VPR PATS",43,0 )
  24752    . Q:$D(^V PR(560,"AD FN",DFN,DA ))  ;alrea dy subscri bed
  24753   "RTN","VPR PATS",44,0 )
  24754    . S TOKEN =DA_"~"_NO W,NEW(TOKE N)=""
  24755   "RTN","VPR PATS",45,0 )
  24756    . S ^XTMP ("VPRX",TO KEN,DFN)=" "
  24757   "RTN","VPR PATS",46,0 )
  24758    I $D(NEW)  D SEND^VP RHTTP(.NEW ) ;send po ke to each  URL with  list TOKEN
  24759   "RTN","VPR PATS",47,0 )
  24760    Q
  24761   "RTN","VPR PATS",48,0 )
  24762    ;
  24763   "RTN","VPR PATS",49,0 )
  24764   GTALLLST(V PR,VPRTYPE ) ;
  24765   "RTN","VPR PATS",50,0 )
  24766    S VPR=$NA (^TMP($J," VPR")) K @ VPR
  24767   "RTN","VPR PATS",51,0 )
  24768    N VPRI,VP RSITE,VPRU SER,VPRSTA
  24769   "RTN","VPR PATS",52,0 )
  24770    S VPRUSER =DUZ,VPRSI TE=DUZ(2), VPRSTA=$$S TA^XUAF4(D UZ(2)),VPR I=0
  24771   "RTN","VPR PATS",53,0 )
  24772    D ADD("<r esults>")
  24773   "RTN","VPR PATS",54,0 )
  24774    I $D(VPRT YPE("ALL") )>0 S (VPR TYPE("OR") ,VPRTYPE(" PXRM"),VPR TYPE("PCMM "))=""
  24775   "RTN","VPR PATS",55,0 )
  24776    D ADD("<l ists>")
  24777   "RTN","VPR PATS",56,0 )
  24778    I $D(VPRT YPE("OR")) >0 D GETOE RRL
  24779   "RTN","VPR PATS",57,0 )
  24780    I $D(VPRT YPE("PXRM" ))>0 D GET PXRML
  24781   "RTN","VPR PATS",58,0 )
  24782    I $D(VPRT YPE("PCMM" ))>0 D GET PCMML
  24783   "RTN","VPR PATS",59,0 )
  24784    D ADD("</ lists>")
  24785   "RTN","VPR PATS",60,0 )
  24786    D ADD("</ results>")
  24787   "RTN","VPR PATS",61,0 )
  24788    Q
  24789   "RTN","VPR PATS",62,0 )
  24790    ;
  24791   "RTN","VPR PATS",63,0 )
  24792   GETLSTPT(V PR,VPRLIST ) ;
  24793   "RTN","VPR PATS",64,0 )
  24794    S VPR=$NA (^TMP($J," VPR")) K @ VPR
  24795   "RTN","VPR PATS",65,0 )
  24796    N GBL,IEN ,TAG,VPRI, VPRSITE,VP RUSER,VPRS TA
  24797   "RTN","VPR PATS",66,0 )
  24798    S VPRUSER =DUZ,VPRSI TE=DUZ(2), VPRSTA=$$S TA^XUAF4(D UZ(2)),VPR I=0
  24799   "RTN","VPR PATS",67,0 )
  24800    D ADD("<r esults>")
  24801   "RTN","VPR PATS",68,0 )
  24802    S GBL=VPR LIST("glob al"),IEN=V PRLIST("ie n")
  24803   "RTN","VPR PATS",69,0 )
  24804    S TAG=$S( GBL="OR":" GETOERRP", GBL="PXRMX P":"GETPXR MP",GBL="P CMM":"GETP CMMP",1:"" )
  24805   "RTN","VPR PATS",70,0 )
  24806    I TAG'="" ,IEN'="" D  @(TAG_"(I EN)")
  24807   "RTN","VPR PATS",71,0 )
  24808    D ADD("</ results>")
  24809   "RTN","VPR PATS",72,0 )
  24810    Q
  24811   "RTN","VPR PATS",73,0 )
  24812    Q
  24813   "RTN","VPR PATS",74,0 )
  24814    ;
  24815   "RTN","VPR PATS",75,0 )
  24816   GETPCMML ;
  24817   "RTN","VPR PATS",76,0 )
  24818    N NAME,IE N
  24819   "RTN","VPR PATS",77,0 )
  24820    S NAME=""  F  S NAME =$O(^SCTM( 404.51,"B" ,NAME)) Q: NAME=""  D
  24821   "RTN","VPR PATS",78,0 )
  24822    .S IEN=$O (^SCTM(404 .51,"B",NA ME,"")) Q: IEN'>0
  24823   "RTN","VPR PATS",79,0 )
  24824    .D ADD("< list value ='"_NAME_" ' id='"_IE N_"' globa l='PCMM'/> ")
  24825   "RTN","VPR PATS",80,0 )
  24826    Q
  24827   "RTN","VPR PATS",81,0 )
  24828    ;
  24829   "RTN","VPR PATS",82,0 )
  24830   GETPCMMP(I EN) ;
  24831   "RTN","VPR PATS",83,0 )
  24832    N DFN,OK, VPRERR,VPR X
  24833   "RTN","VPR PATS",84,0 )
  24834    K ^TMP($J ,"PCM")
  24835   "RTN","VPR PATS",85,0 )
  24836    S OK=$$PT TM^SCAPMC( IEN,"SCDT" ,"^TMP($J, ""PCM"")", .VPRERR)
  24837   "RTN","VPR PATS",86,0 )
  24838    I OK'>0 Q
  24839   "RTN","VPR PATS",87,0 )
  24840    S DFN=0 F   S DFN=$O (^TMP($J," PCM","SCPT A",DFN)) Q :DFN'>0  D
  24841   "RTN","VPR PATS",88,0 )
  24842    .S VPRX(D FN)=""
  24843   "RTN","VPR PATS",89,0 )
  24844    D XML(.VP RX)
  24845   "RTN","VPR PATS",90,0 )
  24846    Q
  24847   "RTN","VPR PATS",91,0 )
  24848    ;
  24849   "RTN","VPR PATS",92,0 )
  24850   GETPXRML ;
  24851   "RTN","VPR PATS",93,0 )
  24852    N NAME,IE N
  24853   "RTN","VPR PATS",94,0 )
  24854    S NAME=""  F  S NAME =$O(^PXRMX P(810.5,"B ",NAME)) Q :NAME=""   D
  24855   "RTN","VPR PATS",95,0 )
  24856    .S IEN=$O (^PXRMXP(8 10.5,"B",N AME,"")) Q :IEN'>0
  24857   "RTN","VPR PATS",96,0 )
  24858    .D ADD("< list value ='"_NAME_" ' id='"_IE N_"' globa l='PXRMXP' />")
  24859   "RTN","VPR PATS",97,0 )
  24860    Q
  24861   "RTN","VPR PATS",98,0 )
  24862    ;
  24863   "RTN","VPR PATS",99,0 )
  24864   GETPXRMP(I EN) ;
  24865   "RTN","VPR PATS",100, 0)
  24866    N CNT,VPR X
  24867   "RTN","VPR PATS",101, 0)
  24868    S CNT=0 F   S CNT=$O (^PXRMXP(8 10.5,IEN,3 0,CNT)) Q: CNT'>0  D
  24869   "RTN","VPR PATS",102, 0)
  24870    .S VPRX(+ $G(^PXRMXP (810.5,IEN ,30,CNT,0) ))=""
  24871   "RTN","VPR PATS",103, 0)
  24872    D XML(.VP RX)
  24873   "RTN","VPR PATS",104, 0)
  24874    Q
  24875   "RTN","VPR PATS",105, 0)
  24876    ;
  24877   "RTN","VPR PATS",106, 0)
  24878   GETOERRL ;
  24879   "RTN","VPR PATS",107, 0)
  24880    N NAME,IE N
  24881   "RTN","VPR PATS",108, 0)
  24882    S NAME=""  F  S NAME =$O(^OR(10 0.21,"B",N AME)) Q:NA ME=""  D
  24883   "RTN","VPR PATS",109, 0)
  24884    .S IEN=$O (^OR(100.2 1,"B",NAME ,"")) Q:IE N'>0
  24885   "RTN","VPR PATS",110, 0)
  24886    .D ADD("< list value ='"_NAME_" ' id='"_IE N_"' globa l='OR'/>")
  24887   "RTN","VPR PATS",111, 0)
  24888    Q
  24889   "RTN","VPR PATS",112, 0)
  24890    ;
  24891   "RTN","VPR PATS",113, 0)
  24892   GETOERRP(I EN) ;
  24893   "RTN","VPR PATS",114, 0)
  24894    N CNT,VPR X
  24895   "RTN","VPR PATS",115, 0)
  24896    S CNT=0 F   S CNT=$O (^OR(100.2 1,IEN,10,C NT)) Q:CNT '>0  D
  24897   "RTN","VPR PATS",116, 0)
  24898    .S VPRX(+ $G(^OR(100 .21,IEN,10 ,CNT,0)))= ""
  24899   "RTN","VPR PATS",117, 0)
  24900    D XML(.VP RX)
  24901   "RTN","VPR PATS",118, 0)
  24902    Q
  24903   "RTN","VPR PATS",119, 0)
  24904    ;
  24905   "RTN","VPR PATS",120, 0)
  24906   IN(VPR) ;  -- Return  current in patients
  24907   "RTN","VPR PATS",121, 0)
  24908    ; RPC = V PR INPATIE NTS
  24909   "RTN","VPR PATS",122, 0)
  24910    N WARD,DF N,VPRX,VPR I
  24911   "RTN","VPR PATS",123, 0)
  24912    S WARD=""  F  S WARD =$O(^DPT(" CN",WARD))  Q:WARD=""   D
  24913   "RTN","VPR PATS",124, 0)
  24914    . S DFN=0  F  S DFN= $O(^DPT("C N",WARD,DF N)) Q:DFN< 1  S VPRX( DFN)=""
  24915   "RTN","VPR PATS",125, 0)
  24916    S VPR=$NA (^TMP($J," VPR")) K @ VPR
  24917   "RTN","VPR PATS",126, 0)
  24918    D XML(.VP RX)
  24919   "RTN","VPR PATS",127, 0)
  24920    Q
  24921   "RTN","VPR PATS",128, 0)
  24922    ;
  24923   "RTN","VPR PATS",129, 0)
  24924   OUT(VPR,BE G,END) ; - - Return p atients w/ appointmen ts [tomorr ow]
  24925   "RTN","VPR PATS",130, 0)
  24926    ; RPC = V PR APPOINT MENTS
  24927   "RTN","VPR PATS",131, 0)
  24928    N VPRX,VP RN,DFN,VPR DT,VPRI,VP RA
  24929   "RTN","VPR PATS",132, 0)
  24930    I '$G(BEG ) D   ;def ault = tom orrow, if  not passed  in
  24931   "RTN","VPR PATS",133, 0)
  24932    . S BEG=$ $FMADD^XLF DT(DT,1),E ND=BEG
  24933   "RTN","VPR PATS",134, 0)
  24934    ; find pa tients wit h appointm ents
  24935   "RTN","VPR PATS",135, 0)
  24936    S END=$G( END,BEG),V PRX(1)=BEG _";"_END
  24937   "RTN","VPR PATS",136, 0)
  24938    S VPRX("S ORT")="P", VPRX("FLDS ")=1,VPRX( 3)="R;I;NT "
  24939   "RTN","VPR PATS",137, 0)
  24940    S VPRN=$$ SDAPI^SDAM A301(.VPRX ) Q:VPRN<1   K VPRX
  24941   "RTN","VPR PATS",138, 0)
  24942    S DFN=0 F   S DFN=$O (^TMP($J," SDAMA301", DFN)) Q:DF N<1  S VPR X(DFN)=""
  24943   "RTN","VPR PATS",139, 0)
  24944    ; find pa tients sch eduled for  admission
  24945   "RTN","VPR PATS",140, 0)
  24946    S VPRDT=0  F  S VPRD T=$O(^DGS( 41.1,"C",V PRDT)) Q:V PRDT<1!(VP RDT>END)   D
  24947   "RTN","VPR PATS",141, 0)
  24948    . S VPRI= 0 F  S VPR I=$O(^DGS( 41.1,"C",V PRDT,VPRI) ) Q:VPRI<1   D
  24949   "RTN","VPR PATS",142, 0)
  24950    .. S VPRA =$G(^DGS(4 1.1,VPRI))
  24951   "RTN","VPR PATS",143, 0)
  24952    .. Q:$P(V PRA,U,13)   Q:$P(VPRA ,U,17)  ;c ancelled o r admitted
  24953   "RTN","VPR PATS",144, 0)
  24954    .. S DFN= +VPRA S:DF N VPRX(DFN )=""
  24955   "RTN","VPR PATS",145, 0)
  24956    ; return  list
  24957   "RTN","VPR PATS",146, 0)
  24958    S VPR=$NA (^TMP($J," VPR")) K @ VPR
  24959   "RTN","VPR PATS",147, 0)
  24960    D XML(.VP RX)
  24961   "RTN","VPR PATS",148, 0)
  24962    Q
  24963   "RTN","VPR PATS",149, 0)
  24964    ;
  24965   "RTN","VPR PATS",150, 0)
  24966   XML(PATIEN T) ; -- Re turn patie nt list as  XML
  24967   "RTN","VPR PATS",151, 0)
  24968    N DFN,ICN ,Y
  24969   "RTN","VPR PATS",152, 0)
  24970    D ADD("<p atients>")
  24971   "RTN","VPR PATS",153, 0)
  24972    S DFN=0 F   S DFN=$O (PATIENT(D FN)) Q:DFN <1  D
  24973   "RTN","VPR PATS",154, 0)
  24974    . S ICN=$ $GETICN^MP IF001(DFN)
  24975   "RTN","VPR PATS",155, 0)
  24976    . S Y="<p atient id= '"_DFN_$S( ICN:"' icn ='"_ICN,1: "")_"' />"  D ADD(Y)
  24977   "RTN","VPR PATS",156, 0)
  24978    D ADD("</ patients>" )
  24979   "RTN","VPR PATS",157, 0)
  24980    Q
  24981   "RTN","VPR PATS",158, 0)
  24982    ;
  24983   "RTN","VPR PATS",159, 0)
  24984   SUBS(VPR,S YS,ON,LIST ) ; -- Un/ Subscribe  to Patient  Data Moni tor
  24985   "RTN","VPR PATS",160, 0)
  24986    ; RPC = V PR SUBSCRI BE
  24987   "RTN","VPR PATS",161, 0)
  24988    N DA,I,IC N,DFN,HDR, VPRI
  24989   "RTN","VPR PATS",162, 0)
  24990    S SYS=$G( SYS),ON=+$ G(ON) Q:'$ L(SYS)
  24991   "RTN","VPR PATS",163, 0)
  24992    S DA=$$FI ND(SYS) Q: DA<1
  24993   "RTN","VPR PATS",164, 0)
  24994    S VPR=$NA (^TMP("VPR ",$J)) K @ VPR
  24995   "RTN","VPR PATS",165, 0)
  24996    S:'$D(^XT MP("VPR"))  ^XTMP("VP R",0)="399 1231^"_DT_ "^VPR Pati ent Data M onitor"
  24997   "RTN","VPR PATS",166, 0)
  24998    ;
  24999   "RTN","VPR PATS",167, 0)
  25000    ; loop th rough LIST (n) = 'dfn ;icn'
  25001   "RTN","VPR PATS",168, 0)
  25002    D ADD("<p atients>")
  25003   "RTN","VPR PATS",169, 0)
  25004    S I="" F   S I=$O(LI ST(I)) Q:I =""  S DFN =LIST(I) D
  25005   "RTN","VPR PATS",170, 0)
  25006    . S ICN=+ $P(DFN,";" ,2),DFN=+$ G(DFN)
  25007   "RTN","VPR PATS",171, 0)
  25008    . I 'DFN  S DFN=+$$G ETDFN^MPIF 001(ICN)
  25009   "RTN","VPR PATS",172, 0)
  25010    . I DFN<1 !'$D(^DPT( DFN)) D RE T(DFN,"err or") Q
  25011   "RTN","VPR PATS",173, 0)
  25012    . I ON D   Q
  25013   "RTN","VPR PATS",174, 0)
  25014    .. S:'$D( ^VPR(560,D A,1,DFN,0) ) HDR=$G(^ VPR(560,DA ,1,0)),^(0 )="^560.01 P^"_DFN_U_ ($P(HDR,U, 4)+1)
  25015   "RTN","VPR PATS",175, 0)
  25016    .. S ^VPR (560,DA,1, DFN,0)=DFN _U_ON,^VPR (560,"ADFN ",DFN,DA)= ""
  25017   "RTN","VPR PATS",176, 0)
  25018    .. D RET( DFN,"on")
  25019   "RTN","VPR PATS",177, 0)
  25020    . ; else,  remove pa tient trac king info  from ^XTMP
  25021   "RTN","VPR PATS",178, 0)
  25022    . S:$D(^V PR(560,DA, 1,DFN,0))  $P(^(0),U, 2)=0
  25023   "RTN","VPR PATS",179, 0)
  25024    . K ^VPR( 560,"ADFN" ,DFN,DA)
  25025   "RTN","VPR PATS",180, 0)
  25026    . D RET(D FN,"off")
  25027   "RTN","VPR PATS",181, 0)
  25028    D ADD("</ patients>" )
  25029   "RTN","VPR PATS",182, 0)
  25030    Q
  25031   "RTN","VPR PATS",183, 0)
  25032    ;
  25033   "RTN","VPR PATS",184, 0)
  25034   FIND(ID) ;  -- Return  ien of sy stem ID in  ^VPR
  25035   "RTN","VPR PATS",185, 0)
  25036    N DA,DO,D IC,X,Y
  25037   "RTN","VPR PATS",186, 0)
  25038    I $G(ID)= "" Q 0                           ;error
  25039   "RTN","VPR PATS",187, 0)
  25040    S DA=+$O( ^VPR(560," B",ID,0))  I DA<1 D   ;add
  25041   "RTN","VPR PATS",188, 0)
  25042    . S DIC=" ^VPR(560," ,DIC(0)="F ",X=ID
  25043   "RTN","VPR PATS",189, 0)
  25044    . D FILE^ DICN S DA= +Y
  25045   "RTN","VPR PATS",190, 0)
  25046    Q DA
  25047   "RTN","VPR PATS",191, 0)
  25048    ;
  25049   "RTN","VPR PATS",192, 0)
  25050   ZFIND(URL)  ; -- Retu rn ien of  URL in ^VP R
  25051   "RTN","VPR PATS",193, 0)
  25052    N NAME,DA  S NAME=$G (URL)
  25053   "RTN","VPR PATS",194, 0)
  25054    S:NAME?1" http".E NA ME=$P(NAME ,"/",3) S: NAME[":" N AME=$P(NAM E,":")
  25055   "RTN","VPR PATS",195, 0)
  25056    S DA=0 F   S DA=$O(^ VPR(560,"B ",NAME,DA) ) Q:DA<1   I $G(^VPR( 560,DA,.1) )=URL Q
  25057   "RTN","VPR PATS",196, 0)
  25058    I DA<1 D   ;add
  25059   "RTN","VPR PATS",197, 0)
  25060    . N DO,DI C,X,Y
  25061   "RTN","VPR PATS",198, 0)
  25062    . S DIC=" ^VPR(560," ,DIC(0)="F ",X=NAME
  25063   "RTN","VPR PATS",199, 0)
  25064    . D FILE^ DICN S DA= +Y
  25065   "RTN","VPR PATS",200, 0)
  25066    . S:DA>0  ^VPR(560,D A,.1)=URL
  25067   "RTN","VPR PATS",201, 0)
  25068    Q DA
  25069   "RTN","VPR PATS",202, 0)
  25070    ;
  25071   "RTN","VPR PATS",203, 0)
  25072   RET(DFN,ST S) ; -- ad d XML node  for patie nt DFN upd ate subscr iption
  25073   "RTN","VPR PATS",204, 0)
  25074    N Y S Y=" <patient d fn='"_$G(D FN)
  25075   "RTN","VPR PATS",205, 0)
  25076    S Y=Y_"'  subscribe= '"_$G(STS) _"' />"
  25077   "RTN","VPR PATS",206, 0)
  25078    D ADD(Y)
  25079   "RTN","VPR PATS",207, 0)
  25080    Q
  25081   "RTN","VPR PATS",208, 0)
  25082    ;
  25083   "RTN","VPR PATS",209, 0)
  25084   ADD(X) ; A dd a line  @VPR@(n)=X
  25085   "RTN","VPR PATS",210, 0)
  25086    S VPRI=$G (VPRI)+1
  25087   "RTN","VPR PATS",211, 0)
  25088    S @VPR@(V PRI)=X
  25089   "RTN","VPR PATS",212, 0)
  25090    Q
  25091   "RTN","VPR PRODC")
  25092   0^18^B2553 308
  25093   "RTN","VPR PRODC",1,0 )
  25094   VPRPRODC ; SLC/AGP -  Environmen tal check  for instal lations ;0 2/02/12
  25095   "RTN","VPR PRODC",2,0 )
  25096    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  25097   "RTN","VPR PRODC",3,0 )
  25098    ;
  25099   "RTN","VPR PRODC",4,0 )
  25100    ;This rou tine will  check to s ee if the  user is in  a product ion accoun t
  25101   "RTN","VPR PRODC",5,0 )
  25102    ;if they  are then t he user wi ll not be  allowed to  install t his
  25103   "RTN","VPR PRODC",6,0 )
  25104    ;patch/bu ild/bundle
  25105   "RTN","VPR PRODC",7,0 )
  25106    ;
  25107   "RTN","VPR PRODC",8,0 )
  25108   ENV ;
  25109   "RTN","VPR PRODC",9,0 )
  25110    I $$PROD^ XUPROD D
  25111   "RTN","VPR PRODC",10, 0)
  25112    .W !,"You  are attem pting to i nstall thi s software  into your  productio n account. ",!,"At th is time, t his softwa re is not  ready for  a producti on install ."
  25113   "RTN","VPR PRODC",11, 0)
  25114    .W !!,"Pl ease verif y the acco unt you're  attemptin g to insta ll into an d",!,"if y ou believe  you're co rrect, con tact Ron M assey or T ana Defa." ,!!,"INSTA LLATION AB ORTED!"
  25115   "RTN","VPR PRODC",12, 0)
  25116    .S XPDABO RT=1
  25117   "RTN","VPR PRODC",13, 0)
  25118    Q
  25119   "RTN","VPR PXRM")
  25120   0^60^B1224 4143
  25121   "RTN","VPR PXRM",1,0)
  25122   VPRPXRM ;  SLC/AGP -  Clinical R emidners r outine. ;  8/16/12 7: 09pm
  25123   "RTN","VPR PXRM",2,0)
  25124    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  25125   "RTN","VPR PXRM",3,0)
  25126    Q
  25127   "RTN","VPR PXRM",4,0)
  25128    ;
  25129   "RTN","VPR PXRM",5,0)
  25130   EVALLIST(R ESULT,PT,U SER,LOC) ;
  25131   "RTN","VPR PXRM",6,0)
  25132    N CNT,NUM ,RIEN,TMP, UID,VPRTMP ,VPRSYS
  25133   "RTN","VPR PXRM",7,0)
  25134    N DUEDATE ,I,J,LASTD ONE,NAME,N ODE,STATUS ,TXT
  25135   "RTN","VPR PXRM",8,0)
  25136    ;S USER=$ P(USERUID, ":",5)
  25137   "RTN","VPR PXRM",9,0)
  25138    D GETLIST ^ORQQPX(.V PRTMP,LOC)
  25139   "RTN","VPR PXRM",10,0 )
  25140    S VPRSYS= $$GET^XPAR ("SYS","VP R SYSTEM N AME")
  25141   "RTN","VPR PXRM",11,0 )
  25142    S CNT=0,N UM=0 F  S  CNT=$O(VPR TMP(CNT))  Q:CNT'>0   D
  25143   "RTN","VPR PXRM",12,0 )
  25144    .S RIEN=$ G(VPRTMP(C NT)) I RIE N'>0 Q
  25145   "RTN","VPR PXRM",13,0 )
  25146    .S NAME=" " S NAME=$ P($G(^PXD( 811.9,RIEN ,0)),U,3)
  25147   "RTN","VPR PXRM",14,0 )
  25148    .I NAME=" " S NAME=$ P($G(^PXD( 811.9,RIEN ,0)),U)
  25149   "RTN","VPR PXRM",15,0 )
  25150    .S UID="u rn:va:pxrm :"_VPRSYS_ ":"_RIEN
  25151   "RTN","VPR PXRM",16,0 )
  25152    .S NUM=NU M+1,TMP("r eminders", NUM,"uid") =UID,TMP(" reminders" ,NUM,"name ")=NAME
  25153   "RTN","VPR PXRM",17,0 )
  25154    .K ^TMP(" PXRHM",$J)
  25155   "RTN","VPR PXRM",18,0 )
  25156    .D MAIN^P XRM(PT,RIE N,5)     ;  5 returns  all remin der info
  25157   "RTN","VPR PXRM",19,0 )
  25158    .S I=1,TX T=""
  25159   "RTN","VPR PXRM",20,0 )
  25160    .S NAME=" ",NAME=$O( ^TMP("PXRH M",$J,RIEN ,NAME)) Q: NAME=""  D
  25161   "RTN","VPR PXRM",21,0 )
  25162    ..S NODE= $G(^TMP("P XRHM",$J,R IEN,NAME))
  25163   "RTN","VPR PXRM",22,0 )
  25164    ..S STATU S=$P(NODE, U),DUEDATE =$$JSONDT^ VPRUTILS($ P(NODE,U,2 )),LASTDON E=$$JSONDT ^VPRUTILS( $P(NODE,U, 3))
  25165   "RTN","VPR PXRM",23,0 )
  25166    ..S J=0 F   S J=$O(^ TMP("PXRHM ",$J,RIEN, NAME,"TXT" ,J)) Q:J=" "  D
  25167   "RTN","VPR PXRM",24,0 )
  25168    ...S TXT= $G(TXT)_^T MP("PXRHM" ,$J,RIEN,N AME,"TXT", J)_$C(13)_ $C(10),I=I +1
  25169   "RTN","VPR PXRM",25,0 )
  25170    .K ^TMP(" PXRHM",$J)
  25171   "RTN","VPR PXRM",26,0 )
  25172    .S TMP("r eminders", NUM,"statu s")=STATUS
  25173   "RTN","VPR PXRM",27,0 )
  25174    .S TMP("r eminders", NUM,"dueDa te")=DUEDA TE
  25175   "RTN","VPR PXRM",28,0 )
  25176    .S TMP("r eminders", NUM,"lastD one")=LAST DONE
  25177   "RTN","VPR PXRM",29,0 )
  25178    .S TMP("r eminders", NUM,"clini calMainten ance")=TXT
  25179   "RTN","VPR PXRM",30,0 )
  25180    S TMP("su ccess")="t rue"
  25181   "RTN","VPR PXRM",31,0 )
  25182    D ENCODE^ VPRJSON("T MP","RESUL T","ERROR" )
  25183   "RTN","VPR PXRM",32,0 )
  25184    I $D(ERRO R) D SETER ROR(.TMP,. ERROR,.RES ULT)
  25185   "RTN","VPR PXRM",33,0 )
  25186    Q
  25187   "RTN","VPR PXRM",34,0 )
  25188    ;
  25189   "RTN","VPR PXRM",35,0 )
  25190   EVALREM(RE SULT,PT,UI D) ;return  detail fo r a pt's c linical re minder
  25191   "RTN","VPR PXRM",36,0 )
  25192    K ^TMP("P XRHM",$J)
  25193   "RTN","VPR PXRM",37,0 )
  25194    N DUEDATE ,I,J,LASTD ONE,NAME,N ODE,RIEN,S TATUS,TMP, TXT
  25195   "RTN","VPR PXRM",38,0 )
  25196    S RIEN=$P (UID,":",5 )
  25197   "RTN","VPR PXRM",39,0 )
  25198    D MAIN^PX RM(PT,RIEN ,5)     ;  5 returns  all remind er info
  25199   "RTN","VPR PXRM",40,0 )
  25200    S I=1,TXT =""
  25201   "RTN","VPR PXRM",41,0 )
  25202    S NAME="" ,NAME=$O(^ TMP("PXRHM ",$J,RIEN, NAME)) Q:N AME=""  D
  25203   "RTN","VPR PXRM",42,0 )
  25204    .S NODE=$ G(^TMP("PX RHM",$J,RI EN,NAME))
  25205   "RTN","VPR PXRM",43,0 )
  25206    .S STATUS =$P(NODE,U ),DUEDATE= $$JSONDT^V PRUTILS($P (NODE,U,2) ),LASTDONE =$$JSONDT^ VPRUTILS($ P(NODE,U,3 ))
  25207   "RTN","VPR PXRM",44,0 )
  25208    .S J=0 F   S J=$O(^T MP("PXRHM" ,$J,RIEN,N AME,"TXT", J)) Q:J=""   D
  25209   "RTN","VPR PXRM",45,0 )
  25210    ..S TXT=$ G(TXT)_^TM P("PXRHM", $J,RIEN,NA ME,"TXT",J )_$C(13)_$ C(10),I=I+ 1
  25211   "RTN","VPR PXRM",46,0 )
  25212    K ^TMP("P XRHM",$J)
  25213   "RTN","VPR PXRM",47,0 )
  25214    S TMP("ui d")=UID
  25215   "RTN","VPR PXRM",48,0 )
  25216    S TMP("st atus")=STA TUS
  25217   "RTN","VPR PXRM",49,0 )
  25218    S TMP("du eDate")=DU EDATE
  25219   "RTN","VPR PXRM",50,0 )
  25220    S TMP("la stDone")=L ASTDONE
  25221   "RTN","VPR PXRM",51,0 )
  25222    S TMP("cl inicalMain tenance")= TXT
  25223   "RTN","VPR PXRM",52,0 )
  25224    S TMP("su ccess")="t rue"
  25225   "RTN","VPR PXRM",53,0 )
  25226    D ENCODE^ VPRJSON("T MP","RESUL T","ERROR" )
  25227   "RTN","VPR PXRM",54,0 )
  25228    I $D(ERRO R) D SETER ROR(.TMP,. ERROR,.RES ULT)
  25229   "RTN","VPR PXRM",55,0 )
  25230    Q
  25231   "RTN","VPR PXRM",56,0 )
  25232    ;
  25233   "RTN","VPR PXRM",57,0 )
  25234   REMLIST(RE SULT,USERU ID,LOC) ;
  25235   "RTN","VPR PXRM",58,0 )
  25236    N CNT,NUM ,RIEN,TMP, UID,USER,V PRTMP,VPRS YS
  25237   "RTN","VPR PXRM",59,0 )
  25238    S USER=$P (USERUID," :",5)
  25239   "RTN","VPR PXRM",60,0 )
  25240    D GETLIST ^ORQQPX(.V PRTMP,LOC)
  25241   "RTN","VPR PXRM",61,0 )
  25242    S VPRSYS= $$GET^XPAR ("SYS","VP R SYSTEM N AME")
  25243   "RTN","VPR PXRM",62,0 )
  25244    S CNT=0,N UM=0 F  S  CNT=$O(VPR TMP(CNT))  Q:CNT'>0   D
  25245   "RTN","VPR PXRM",63,0 )
  25246    .S RIEN=$ G(VPRTMP(C NT)) I RIE N'>0 Q
  25247   "RTN","VPR PXRM",64,0 )
  25248    .S NAME=" " S NAME=$ P($G(^PXD( 811.9,RIEN ,0)),U,3)
  25249   "RTN","VPR PXRM",65,0 )
  25250    .I NAME=" " S NAME=$ P($G(^PXD( 811.9,RIEN ,0)),U)
  25251   "RTN","VPR PXRM",66,0 )
  25252    .S UID="u rn:va:pxrm :"_VPRSYS_ ":"_RIEN
  25253   "RTN","VPR PXRM",67,0 )
  25254    .S NUM=NU M+1,TMP("r eminders", NUM,"uid") =UID,TMP(" reminders" ,NUM,"name ")=NAME
  25255   "RTN","VPR PXRM",68,0 )
  25256    S TMP("su ccess")="t rue"
  25257   "RTN","VPR PXRM",69,0 )
  25258    D ENCODE^ VPRJSON("T MP","RESUL T","ERROR" )
  25259   "RTN","VPR PXRM",70,0 )
  25260    I $D(ERRO R) D SETER ROR(.TMP,. ERROR,.RES ULT)
  25261   "RTN","VPR PXRM",71,0 )
  25262    Q
  25263   "RTN","VPR PXRM",72,0 )
  25264    ;
  25265   "RTN","VPR PXRM",73,0 )
  25266   SETERROR(I NPDATA,ERR ORMSG,OUTP UT) ;
  25267   "RTN","VPR PXRM",74,0 )
  25268    N ERRARR, TXT
  25269   "RTN","VPR PXRM",75,0 )
  25270    S TXT(1)= "Problem e ncoding js on output"
  25271   "RTN","VPR PXRM",76,0 )
  25272    D SETERRO R^VPRUTILS (.ERRARR,. ERRORMSG,. TXT,.INPDA TA)
  25273   "RTN","VPR PXRM",77,0 )
  25274    D ENCODE^ VPRJSON("E RRARR","OU TPUT","ERR OR")
  25275   "RTN","VPR PXRM",78,0 )
  25276    Q
  25277   "RTN","VPR PXRM",79,0 )
  25278    ;
  25279   "RTN","VPR ROS2")
  25280   0^13^B1065 16600
  25281   "RTN","VPR ROS2",1,0)
  25282   VPRROS2 ;S LC/GRR --  Roster Man agement
  25283   "RTN","VPR ROS2",2,0)
  25284    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  25285   "RTN","VPR ROS2",3,0)
  25286    ;; Compil e Roster
  25287   "RTN","VPR ROS2",4,0)
  25288   COMPILE(VP R,VPRIEN,V PROWNER) ;
  25289   "RTN","VPR ROS2",5,0)
  25290    ;; Input  - VPRIEN i s internal  entry num ber of ros ter
  25291   "RTN","VPR ROS2",6,0)
  25292    ;;          VPROWNER  - If this  parameter  exists, o nly roster s for this  owner wil l be compi led and pa ssed
  25293   "RTN","VPR ROS2",7,0)
  25294    ;; Output  - AFTER a rray conta ins curren t patients
  25295   "RTN","VPR ROS2",8,0)
  25296    ;
  25297   "RTN","VPR ROS2",9,0)
  25298    K VPRLIST ,VPRLIST2
  25299   "RTN","VPR ROS2",10,0 )
  25300    N VPRLIST ,VPRFILT,V PRTYPE,VPE RR,VPRI,VP RRNAME,VPR Y,VPROP,VP RTAG,VPRLA B,VPRNLIST ,BEG,DOB,E ND,GENDER, ICN,NAME,V PRACT,VPRC
  25301   "RTN","VPR ROS2",11,0 )
  25302    N VPRCIEN ,VPRDNAME, VPRDOB,VPR III,VPRINM ,VPRLIEN,V PRNAME,VPR OIEN,VPRON AME,VPROWN ID,VPROWNN M,VPRPAT,V PRPIEN,VPR NME,VPRCNT
  25303   "RTN","VPR ROS2",12,0 )
  25304    N VPRSRCD N,VPRCID,V PRTEXT,VPR TIEN,VPRTL ST,VPRVER, VPRWIEN,VP RWNAME,VPR PNME,VPRRC NT,VPRSRCI D,X,Y
  25305   "RTN","VPR ROS2",13,0 )
  25306    K ^TMP($J ,"VPROSTER ")
  25307   "RTN","VPR ROS2",14,0 )
  25308    S VPR=$NA (^TMP($J," VPROSTER") ),VPRNLIST =""
  25309   "RTN","VPR ROS2",15,0 )
  25310    I $G(VPRI EN)="" S V PRIEN=0
  25311   "RTN","VPR ROS2",16,0 )
  25312    S (VPRLIS T,VPRFILT, VPRTYPE,VP ROP,VPRLIS T2,VPERR)= "",VPRI=0
  25313   "RTN","VPR ROS2",17,0 )
  25314    I $G(VPRO WNER)'=""  D MULTI Q  VPR
  25315   "RTN","VPR ROS2",18,0 )
  25316    I +$G(VPR IEN)'>0 S  VPERR="0^I nvalid Ros ter IEN" Q
  25317   "RTN","VPR ROS2",19,0 )
  25318    S VPRRNAM E=$P(^VPRO STER(VPRIE N,0),"^",1 )
  25319   "RTN","VPR ROS2",20,0 )
  25320    F  S VPRI =$O(^VPROS TER(VPRIEN ,1,VPRI))  Q:VPRI'>0   D
  25321   "RTN","VPR ROS2",21,0 )
  25322    . S VPRY= $G(^VPROST ER(VPRIEN, 1,VPRI,0))
  25323   "RTN","VPR ROS2",22,0 )
  25324    . S VPROP =$P(VPRY," ^",3)
  25325   "RTN","VPR ROS2",23,0 )
  25326    . S VPRFI LT=$P(VPRY ,"^",4)
  25327   "RTN","VPR ROS2",24,0 )
  25328    . S VPRTA G=$P($P(VP RY,"^",2), ";",2)
  25329   "RTN","VPR ROS2",25,0 )
  25330    . S VPRLA B=""
  25331   "RTN","VPR ROS2",26,0 )
  25332    . I VPRTA G["SC(" S  VPRLAB="CL IN"
  25333   "RTN","VPR ROS2",27,0 )
  25334    . I VPRTA G["DIC(42"  S VPRLAB= "WARD"
  25335   "RTN","VPR ROS2",28,0 )
  25336    . I VPRTA G["DPT" S  VPRLAB="PA T"
  25337   "RTN","VPR ROS2",29,0 )
  25338    . I VPRTA G["SCTM" S  VPRLAB="P CMM"
  25339   "RTN","VPR ROS2",30,0 )
  25340    . I VPRTA G["OR(100. 21" S VPRL AB="CPRS"
  25341   "RTN","VPR ROS2",31,0 )
  25342    . I VPRTA G["VPROSTE R" S VPRLA B="ROST"
  25343   "RTN","VPR ROS2",32,0 )
  25344    . I VPRTA G["DIC(45. 7" S VPRLA B="SPEC"
  25345   "RTN","VPR ROS2",33,0 )
  25346    . I VPRTA G["VA(200"  S VPRLAB= "PROV"
  25347   "RTN","VPR ROS2",34,0 )
  25348    . I VPRTA G["PXRM(81 0.4" S VPR LAB="PXRM"
  25349   "RTN","VPR ROS2",35,0 )
  25350    . I VPRLA B="" S VPE RR="1^INVA LID FILE T YPE" Q
  25351   "RTN","VPR ROS2",36,0 )
  25352    . D @VPRL AB
  25353   "RTN","VPR ROS2",37,0 )
  25354    . S VPRLA B=$S(VPROP =0:"UNION" ,VPROP=1:" INTER",1:" DIFF")
  25355   "RTN","VPR ROS2",38,0 )
  25356    . S VPRNL IST=""
  25357   "RTN","VPR ROS2",39,0 )
  25358    . D @VPRL AB
  25359   "RTN","VPR ROS2",40,0 )
  25360    I $D(VPRO UT) K VPRO UT M VPRLI ST2=VPRLIS T Q
  25361   "RTN","VPR ROS2",41,0 )
  25362    I $O(VPRL IST(0))'>0  S VPERR=" 1^EMPTY RO STER",@VPR @(1)=VPERR  Q
  25363   "RTN","VPR ROS2",42,0 )
  25364    M AFTER=V PRLIST
  25365   "RTN","VPR ROS2",43,0 )
  25366    D SEND
  25367   "RTN","VPR ROS2",44,0 )
  25368    D ENROS^V PRFPTC(.ZZ ,.VPRLIST)  ;added 5/ 17/12 grr  to check p atient sen sitivity
  25369   "RTN","VPR ROS2",45,0 )
  25370    Q
  25371   "RTN","VPR ROS2",46,0 )
  25372    ;
  25373   "RTN","VPR ROS2",47,0 )
  25374   CLIN ;Proc ess patien ts for thi s clinic.   Select al l if filte r is null
  25375   "RTN","VPR ROS2",48,0 )
  25376    K VPRLIST 2 S VPRLIS T2=""
  25377   "RTN","VPR ROS2",49,0 )
  25378    I '$D(DT)  S DT=$$DT ^XLFDT()
  25379   "RTN","VPR ROS2",50,0 )
  25380    S BEG=DT, END=$S(VPR FILT="T":D T+.24,1:99 99999+.24) ,VPRIII=BE G
  25381   "RTN","VPR ROS2",51,0 )
  25382    S VPRCIEN =+$P(VPRY, "^",2) F   S VPRIII=$ O(^SC(VPRC IEN,"S",VP RIII)) Q:V PRIII'>0!( VPRIII>END )  D
  25383   "RTN","VPR ROS2",52,0 )
  25384    . S VPRII =0 F  S VP RII=$O(^SC (VPRCIEN," S",VPRIII, 1,VPRII))  Q:VPRII'>0   S DFN=$P ($G(^SC(VP RCIEN,"S", VPRIII,1,V PRII,0))," ^",1) I DF N>0 D
  25385   "RTN","VPR ROS2",53,0 )
  25386    . .S VPRL IST2(DFN)= ""
  25387   "RTN","VPR ROS2",54,0 )
  25388    Q
  25389   "RTN","VPR ROS2",55,0 )
  25390    ;
  25391   "RTN","VPR ROS2",56,0 )
  25392   WARD ;Proc ess patien ts for thi s ward
  25393   "RTN","VPR ROS2",57,0 )
  25394    K VPRLIST 2 S VPRLIS T2=""
  25395   "RTN","VPR ROS2",58,0 )
  25396    S VPRWIEN =+$P(VPRY, "^",2),VPR WNAME=$P($ G(^DIC(42, VPRWIEN,0) ),"^",1)
  25397   "RTN","VPR ROS2",59,0 )
  25398    S VPRIII= 0 F  S VPR III=$O(^DG PM("CN",VP RWNAME,VPR III)) Q:VP RIII'>0  D
  25399   "RTN","VPR ROS2",60,0 )
  25400    . S DFN=$ P($G(^DGPM (VPRIII,0) ),"^",3),V PRLIST2(DF N)=""
  25401   "RTN","VPR ROS2",61,0 )
  25402    Q
  25403   "RTN","VPR ROS2",62,0 )
  25404    ;
  25405   "RTN","VPR ROS2",63,0 )
  25406   PAT ;Proce ss patient  from Pati ent file S ource
  25407   "RTN","VPR ROS2",64,0 )
  25408    K VPRLIST 2 S VPRLIS T2=""
  25409   "RTN","VPR ROS2",65,0 )
  25410    S DFN=+$P (VPRY,"^", 2),VPRLIST 2(DFN)=""
  25411   "RTN","VPR ROS2",66,0 )
  25412    Q
  25413   "RTN","VPR ROS2",67,0 )
  25414    ;
  25415   "RTN","VPR ROS2",68,0 )
  25416   PCMM ;Proc ess patien ts from a  PCMM team
  25417   "RTN","VPR ROS2",69,0 )
  25418    K VPRLIST 2 S VPRLIS T2=""
  25419   "RTN","VPR ROS2",70,0 )
  25420    S VPRTIEN =+$P(VPRY, "^",2),VPE RR="",VPRT LST=""
  25421   "RTN","VPR ROS2",71,0 )
  25422    D PTTM^SC APMC(VPRTI EN,,"VPRTL ST",VPERR)
  25423   "RTN","VPR ROS2",72,0 )
  25424    S VPRIII= "" F  S VP RIII=$O(VP RTLST(VPRI II)) Q:VPR III'>0  S  DFN=$P(VPR TLST(VPRII I),"^",1)  S VPRLIST2 (DFN)=""
  25425   "RTN","VPR ROS2",73,0 )
  25426    Q
  25427   "RTN","VPR ROS2",74,0 )
  25428    ;
  25429   "RTN","VPR ROS2",75,0 )
  25430   CPRS ;Proc ess patien ts from CP RS Lists
  25431   "RTN","VPR ROS2",76,0 )
  25432    K VPRLIST 2 S VPRLIS T2=""
  25433   "RTN","VPR ROS2",77,0 )
  25434    S VPROIEN =+$P(VPRY, "^",2),VPE RR=""
  25435   "RTN","VPR ROS2",78,0 )
  25436    S VPRIII= 0 F  S VPR III=$O(^OR (100.21,VP ROIEN,10,V PRIII)) Q: VPRIII'>0   S DFN=$P( ^OR(100.21 ,VPROIEN,1 0,VPRIII,0 ),";",1) S  VPRLIST2( DFN)=""
  25437   "RTN","VPR ROS2",79,0 )
  25438    Q
  25439   "RTN","VPR ROS2",80,0 )
  25440    ;
  25441   "RTN","VPR ROS2",81,0 )
  25442   ROST ;Proc ess patien ts from se lected ros ter
  25443   "RTN","VPR ROS2",82,0 )
  25444    K VPRLIST 2,VPRBLIST  S (VPRLIS T2,VPRBLIS T)="" ; --  kcm added  comma
  25445   "RTN","VPR ROS2",83,0 )
  25446    N VPR,VPR IEN,VPERR
  25447   "RTN","VPR ROS2",84,0 )
  25448    S VPRIEN= +$P(VPRY," ^",2),VPER R="",VPROU T=1,VPR="V PRBLIST"
  25449   "RTN","VPR ROS2",85,0 )
  25450    D COMPILE ^VPRROS2(. VPR,VPRIEN ,"")
  25451   "RTN","VPR ROS2",86,0 )
  25452    M VPRBLIS T=VPRLIST2
  25453   "RTN","VPR ROS2",87,0 )
  25454    K VPROUT
  25455   "RTN","VPR ROS2",88,0 )
  25456    Q
  25457   "RTN","VPR ROS2",89,0 )
  25458    ;
  25459   "RTN","VPR ROS2",90,0 )
  25460   SPEC ;Proc ess patien ts with se lected Tre ating Spec ialty
  25461   "RTN","VPR ROS2",91,0 )
  25462    K VPRLIST 2 S VPRLIS T2=""
  25463   "RTN","VPR ROS2",92,0 )
  25464    S VPROIEN =+$P(VPRY, "^",2),VPE RR=""
  25465   "RTN","VPR ROS2",93,0 )
  25466    N DFN S D FN=0 F  S  DFN=$O(^DP T("ATR",VP ROIEN,DFN) ) Q:DFN'>0   S VPRLIS T2(DFN)=""
  25467   "RTN","VPR ROS2",94,0 )
  25468    Q
  25469   "RTN","VPR ROS2",95,0 )
  25470    ;
  25471   "RTN","VPR ROS2",96,0 )
  25472   PROV ;Proc ess patien ts for sel ected prov ider
  25473   "RTN","VPR ROS2",97,0 )
  25474    K VPRLIST 2 S VPRLIS T2=""
  25475   "RTN","VPR ROS2",98,0 )
  25476    S VPRPIEN =+$P(VPRY, "^",2),VPE RR=""
  25477   "RTN","VPR ROS2",99,0 )
  25478    N DFN S D FN=0 F  S  DFN=$O(^DP T("APR",VP RPIEN,DFN) ) Q:DFN'>0   S VPRLIS T2(DFN)=""
  25479   "RTN","VPR ROS2",100, 0)
  25480    Q
  25481   "RTN","VPR ROS2",101, 0)
  25482    ;
  25483   "RTN","VPR ROS2",102, 0)
  25484   PXRM ;Proc ess patien ts for sel ected pane l
  25485   "RTN","VPR ROS2",103, 0)
  25486    K VPRLIST 2 S VPRLIS T2=""
  25487   "RTN","VPR ROS2",104, 0)
  25488    S VPRPIEN =+$P(VPRY, "^",2),VPE RR=""
  25489   "RTN","VPR ROS2",105, 0)
  25490    S VPRC=VP RPIEN,VPRL IEN=$P(^VP ROSTER(VPR IEN,0),"^" ,1),VPRPNM E=$P(^VPRO STER(VPRIE N,0),"^",6 ) I VPRPNM E="" S VPR PNME=VPRRN AME,$P(^VP ROSTER(VPR IEN,0),U,6 )=VPRRNAME
  25491   "RTN","VPR ROS2",106, 0)
  25492    S VPRPAT= "" D RUNLI ST^VPRROS5 (.VPRPAT,V PRLIEN,VPR PNME,0,1)
  25493   "RTN","VPR ROS2",107, 0)
  25494    S VPRII=0  F  S VPRI I=$O(VPRPA T(VPRC,VPR II)) Q:VPR II'>0  S D FN=VPRPAT( VPRC,VPRII ),VPRLIST2 (DFN)=""
  25495   "RTN","VPR ROS2",108, 0)
  25496    Q
  25497   "RTN","VPR ROS2",109, 0)
  25498    ;
  25499   "RTN","VPR ROS2",110, 0)
  25500   UNION ;Add  to existi ng list
  25501   "RTN","VPR ROS2",111, 0)
  25502    S VPRII=0  F  S VPRI I=$O(VPRLI ST2(VPRII) ) Q:VPRII' >0  S VPRL IST(VPRII) =""
  25503   "RTN","VPR ROS2",112, 0)
  25504    Q
  25505   "RTN","VPR ROS2",113, 0)
  25506    ;
  25507   "RTN","VPR ROS2",114, 0)
  25508   INTER ;Int ersect wit h existing  list
  25509   "RTN","VPR ROS2",115, 0)
  25510    S VPRII=0  F  S VPRI I=$O(VPRLI ST(VPRII))  Q:VPRII'> 0  D
  25511   "RTN","VPR ROS2",116, 0)
  25512    . I '$D(V PRLIST2(VP RII)) K VP RLIST(VPRI I)
  25513   "RTN","VPR ROS2",117, 0)
  25514    Q
  25515   "RTN","VPR ROS2",118, 0)
  25516    ;
  25517   "RTN","VPR ROS2",119, 0)
  25518   DIFF ;Remo ve patient s from thi s source t hat we hav e so far
  25519   "RTN","VPR ROS2",120, 0)
  25520    S VPRII=0  F  S VPRI I=$O(VPRLI ST2(VPRII) ) Q:VPRII' >0  D
  25521   "RTN","VPR ROS2",121, 0)
  25522    . K VPRLI ST(VPRII)
  25523   "RTN","VPR ROS2",122, 0)
  25524    Q
  25525   "RTN","VPR ROS2",123, 0)
  25526    ;
  25527   "RTN","VPR ROS2",124, 0)
  25528   SEND ;send  pending r osters.  C alled thro ugh RPC
  25529   "RTN","VPR ROS2",125, 0)
  25530    S VPRRCNT =0,VPRI=0, VPRII=0
  25531   "RTN","VPR ROS2",126, 0)
  25532    S VPRVER= "<results  version='" _$P($T(VPR ROS2+1),"; ",3)_"'>"
  25533   "RTN","VPR ROS2",127, 0)
  25534    D ADD(VPR VER)
  25535   "RTN","VPR ROS2",128, 0)
  25536    S VPRRNAM E=$P(^VPRO STER(VPRIE N,0),"^",1 ),VPRDNAME =$P(^VPROS TER(VPRIEN ,0),"^",2) ,VPRRNAME= $$ESC^VPRD (VPRRNAME) ,VPRDNAME= $$ESC^VPRD (VPRDNAME)
  25537   "RTN","VPR ROS2",129, 0)
  25538    S VPRTEXT ="<roster  ien='"_VPR IEN_"'>" D  ADD(VPRTE XT)
  25539   "RTN","VPR ROS2",130, 0)
  25540    S VPRTEXT ="<rosterN ame>"_VPRR NAME_"</ro sterName>"  D ADD(VPR TEXT)
  25541   "RTN","VPR ROS2",131, 0)
  25542    S VPRTEXT ="<display Name>"_VPR DNAME_"</d isplayName >" D ADD(V PRTEXT)
  25543   "RTN","VPR ROS2",132, 0)
  25544    D ADD("<p atients>")
  25545   "RTN","VPR ROS2",133, 0)
  25546    K VPRII S  VPRII=0 F   S VPRII= $O(VPRLIST (VPRII)) Q :VPRII'>0   D
  25547   "RTN","VPR ROS2",134, 0)
  25548    . N VPRY
  25549   "RTN","VPR ROS2",135, 0)
  25550    . S DFN=V PRII,VPRY= $G(^DPT(DF N,0))
  25551   "RTN","VPR ROS2",136, 0)
  25552    . S ICN=$ $GETICN^MP IF001(DFN)
  25553   "RTN","VPR ROS2",137, 0)
  25554    . S NAME= $P(VPRY,"^ ",1),GENDE R=$P(VPRY, "^",2),DOB =$P(VPRY," ^",3),SSN= $P(VPRY,"^ ",9),VPRDO B=$$FMTHL7 ^XLFDT(DOB )
  25555   "RTN","VPR ROS2",138, 0)
  25556    . S Y="<p atient nam e='"_NAME_ "' gender= '"_GENDER_ "' dob='"_ VPRDOB_"'  ssn='"_SSN _"' id='"_ DFN_$S(ICN :"' icn='" _ICN,1:"") _"' />" D  ADD(Y)
  25557   "RTN","VPR ROS2",139, 0)
  25558    D ADD("</ patients>" )
  25559   "RTN","VPR ROS2",140, 0)
  25560    D ADD("</ roster>")
  25561   "RTN","VPR ROS2",141, 0)
  25562    S VPRTEXT ="</result s>" D ADD( VPRTEXT)
  25563   "RTN","VPR ROS2",142, 0)
  25564    Q
  25565   "RTN","VPR ROS2",143, 0)
  25566    ;
  25567   "RTN","VPR ROS2",144, 0)
  25568   ADD(X) ; - - Add a li ne @VPR@(n )=X
  25569   "RTN","VPR ROS2",145, 0)
  25570    S VPRI=$G (VPRI)+1
  25571   "RTN","VPR ROS2",146, 0)
  25572    S @VPR@(V PRI)=X
  25573   "RTN","VPR ROS2",147, 0)
  25574    Q
  25575   "RTN","VPR ROS2",148, 0)
  25576    ;
  25577   "RTN","VPR ROS2",149, 0)
  25578   GETROS(VPR ,VPRFILT)  ;; Get all  Rosters
  25579   "RTN","VPR ROS2",150, 0)
  25580    ;; Input  - None
  25581   "RTN","VPR ROS2",151, 0)
  25582    N VPRLIST ,VPRTYPE,V PERR,VPRI, VPRRNAME,V PRY,VPROP, VPRTAG,VPR LAB,VPRNLI ST,BEG,DOB ,END,GENDE R,ICN,NAME ,VPRACT,VP RC
  25583   "RTN","VPR ROS2",152, 0)
  25584    N VPRCIEN ,VPRDNAME, VPRDOB,VPR III,VPRINM ,VPRLIEN,V PRNAME,VPR OIEN,VPRON AME,VPROWN ID,VPROWNN M,VPRPAT,V PRPIEN,VPR NME,VPRCNT
  25585   "RTN","VPR ROS2",153, 0)
  25586    N VPRSRCD N,VPRCID,V PRTEXT,VPR TIEN,VPRTL ST,VPRVER, VPRWIEN,VP RWNAME,VPR PNME,VPRRC NT,VPRSRCI D,X,Y
  25587   "RTN","VPR ROS2",154, 0)
  25588    K VPRLIST
  25589   "RTN","VPR ROS2",155, 0)
  25590    S (VPRLIS T,VPRNAME, VPRTYPE,VP ROP,VPRLIS T2)="",VPR I=0,VPRIEN =0
  25591   "RTN","VPR ROS2",156, 0)
  25592    S VPRACT= "I 1"
  25593   "RTN","VPR ROS2",157, 0)
  25594    K ^TMP($J ,"VPROSTER ")
  25595   "RTN","VPR ROS2",158, 0)
  25596    S VPR=$NA (^TMP($J," VPROSTER") )
  25597   "RTN","VPR ROS2",159, 0)
  25598    S VPRVER= "<results  version='" _$P($T(VPR ROS2+1),"; ",3)_"'>"
  25599   "RTN","VPR ROS2",160, 0)
  25600    D ADD(VPR VER)
  25601   "RTN","VPR ROS2",161, 0)
  25602    S VPRNAME ="",VPRFIL T=$G(VPRFI LT)
  25603   "RTN","VPR ROS2",162, 0)
  25604    I VPRFILT '="" S X=V PRFILT X ^ %ZOSF("UPP ERCASE") S  VPRFILT=X ,VPRNAME=" ",VPRACT=" I VPRNAME[ VPRFILT"
  25605   "RTN","VPR ROS2",163, 0)
  25606    F  S VPRN AME=$O(^VP ROSTER("B" ,VPRNAME))  Q:VPRNAME =""  S X=V PRNAME X ^ %ZOSF("UPP ERCASE") X  VPRACT D
  25607   "RTN","VPR ROS2",164, 0)
  25608    . S VPRIE N=0 F  S V PRIEN=$O(^ VPROSTER(" B",VPRNAME ,VPRIEN))  Q:VPRIEN'> 0  I '$P(^ VPROSTER(V PRIEN,0)," ^",3)!($P( $G(^VPROST ER(VPRIEN, 3)),"^",1) ']"") X VP RACT I  D 
  25609   "RTN","VPR ROS2",165, 0)
  25610    . . S VPR ONAME=$$ES C^VPRD(VPR NAME),VPRD NAME=$P(^V PROSTER(VP RIEN,0),"^ ",2),VPRDN AME=$$ESC^ VPRD(VPRDN AME)
  25611   "RTN","VPR ROS2",166, 0)
  25612    . . S VPR OWNID=$P(^ VPROSTER(V PRIEN,0)," ^",4),VPRO WNNM=$P($G (^VA(200,V PROWNID,0) ),"^",1),V PROWNNM=$$ ESC^VPRD(V PROWNNM)
  25613   "RTN","VPR ROS2",167, 0)
  25614    . . S VPR TEXT="<ros ter ien='" _VPRIEN_"'   ownernam e='"_VPROW NNM_"'  ow nerid='"_V PROWNID_"' >" D ADD(V PRTEXT)
  25615   "RTN","VPR ROS2",168, 0)
  25616    . . S VPR TEXT="<ros terName>"_ VPRONAME_" </rosterNa me>" D ADD (VPRTEXT)
  25617   "RTN","VPR ROS2",169, 0)
  25618    . . S VPR TEXT="<dis playName>" _VPRDNAME_ "</display Name>" D A DD(VPRTEXT )
  25619   "RTN","VPR ROS2",170, 0)
  25620    . . S VPR TEXT="<sou rces>" D A DD(VPRTEXT )
  25621   "RTN","VPR ROS2",171, 0)
  25622    . . N VPR II,VPRAS S  VPRII=0 F   S VPRII= $O(^VPROST ER(VPRIEN, 1,"AS",VPR II)) Q:VPR II'>0  S V PRAS=$O(^V PROSTER(VP RIEN,1,"AS ",VPRII,0) ) D
  25623   "RTN","VPR ROS2",172, 0)
  25624    . . . N V PRSEQ,VPRS RC,VPRTYP, VPROP,VPRY ,VPRSRCNM
  25625   "RTN","VPR ROS2",173, 0)
  25626    . . . S V PRY=$G(^VP ROSTER(VPR IEN,1,VPRA S,0))
  25627   "RTN","VPR ROS2",174, 0)
  25628    . . . S V PRSRC=$P($ P(VPRY,"^" ,2),";",2)
  25629   "RTN","VPR ROS2",175, 0)
  25630    . . . S V PRSEQ=VPRI I
  25631   "RTN","VPR ROS2",176, 0)
  25632    . . . I V PRSRC["SC( " S VPRSRC NM="Clinic "
  25633   "RTN","VPR ROS2",177, 0)
  25634    . . . I V PRSRC["DIC (42," S VP RSRCNM="Wa rd"
  25635   "RTN","VPR ROS2",178, 0)
  25636    . . . I V PRSRC["DPT (" S VPRSR CNM="Patie nt"
  25637   "RTN","VPR ROS2",179, 0)
  25638    . . . I V PRSRC["SCT M" S VPRSR CNM="PCMM  Team"
  25639   "RTN","VPR ROS2",180, 0)
  25640    . . . I V PRSRC["OR( 100.21" S  VPRSRCNM=" OE/RR"
  25641   "RTN","VPR ROS2",181, 0)
  25642    . . . I V PRSRC["VPR OSTER" S V PRSRCNM="V PR Roster"
  25643   "RTN","VPR ROS2",182, 0)
  25644    . . . I V PRSRC["DIC (45.7" S V PRSRCNM="S pecialty"
  25645   "RTN","VPR ROS2",183, 0)
  25646    . . . I V PRSRC["VA( 200," S VP RSRCNM="Pr ovider"
  25647   "RTN","VPR ROS2",184, 0)
  25648    . . . I V PRSRC["PXR M(810.4,"  S VPRSRCNM ="PXRM"
  25649   "RTN","VPR ROS2",185, 0)
  25650    . . . S V PRSRCID=+$ P(VPRY,"^" ,2),VPRSRC DN="^"_VPR SRC_VPRSRC ID_",0)",V PRINM=$P(@ VPRSRCDN," ^",1),VPRI NM=$$ESC^V PRD(VPRINM )
  25651   "RTN","VPR ROS2",186, 0)
  25652    . . . S V PROP=$S($P (VPRY,"^", 3)=0:"Unio n",$P(VPRY ,"^",3)=1: "Intersect ion",$P(VP RY,"^",3)= 2:"Differe nce",1:"In valid")
  25653   "RTN","VPR ROS2",187, 0)
  25654    . . . S V PRTEXT="<s ource sequ ence='"_VP RSEQ_"'  t ype='"_VPR SRCNM_"'   name='"_VP RINM_"'  i d='"_VPRSR CID_"'  op eration='" _VPROP_"'  />" D ADD( VPRTEXT)
  25655   "RTN","VPR ROS2",188, 0)
  25656    . . S VPR TEXT="</so urces>" D  ADD(VPRTEX T)
  25657   "RTN","VPR ROS2",189, 0)
  25658    . . S VPR TEXT="</ro ster>" D A DD(VPRTEXT )
  25659   "RTN","VPR ROS2",190, 0)
  25660    S VPRTEXT ="</result s>" D ADD( VPRTEXT)
  25661   "RTN","VPR ROS2",191, 0)
  25662    Q
  25663   "RTN","VPR ROS2",192, 0)
  25664    ;
  25665   "RTN","VPR ROS2",193, 0)
  25666   MULTI ;;Pr ocess mult iple roste rs
  25667   "RTN","VPR ROS2",194, 0)
  25668    I $O(^VPR OSTER("AC" ,VPROWNER, 0))'>0 S V PERR="1^EM PTY ROSTER ",@VPR@(1) =VPERR Q
  25669   "RTN","VPR ROS2",195, 0)
  25670    S VPRRCNT =0,VPRI=0, VPRII=0,VP RIII=0
  25671   "RTN","VPR ROS2",196, 0)
  25672    S VPRVER= "<results  version='" _$P($T(VPR ROS2+1),"; ",3)_"'>"
  25673   "RTN","VPR ROS2",197, 0)
  25674    D ADD(VPR VER)
  25675   "RTN","VPR ROS2",198, 0)
  25676    F  S VPRI EN=$O(^VPR OSTER("AC" ,VPROWNER, VPRIEN)) Q :VPRIEN'>0   D
  25677   "RTN","VPR ROS2",199, 0)
  25678    .S VPRRNA ME=$P(^VPR OSTER(VPRI EN,0),"^", 1),VPRDNAM E=$P(^VPRO STER(VPRIE N,0),"^",2 )
  25679   "RTN","VPR ROS2",200, 0)
  25680    .S VPRTEX T="<roster  ien='"_VP RIEN_"'>"  D ADD(VPRT EXT)
  25681   "RTN","VPR ROS2",201, 0)
  25682    .S VPRTEX T="<roster Name>"_VPR RNAME_"</r osterName> " D ADD(VP RTEXT)
  25683   "RTN","VPR ROS2",202, 0)
  25684    .S VPRTEX T="<displa yName>"_VP RDNAME_"</ displayNam e>" D ADD( VPRTEXT)
  25685   "RTN","VPR ROS2",203, 0)
  25686    . S VPRII I=0 F  S V PRIII=$O(^ VPROSTER(V PRIEN,1,VP RIII)) Q:V PRIII'>0   D
  25687   "RTN","VPR ROS2",204, 0)
  25688    .. S VPRY =$G(^VPROS TER(VPRIEN ,1,VPRIII, 0))
  25689   "RTN","VPR ROS2",205, 0)
  25690    .. S VPRO P=$P(VPRY, "^",3)
  25691   "RTN","VPR ROS2",206, 0)
  25692    .. S VPRF ILT=$P(VPR Y,"^",4)
  25693   "RTN","VPR ROS2",207, 0)
  25694    .. S VPRT AG=$P($P(V PRY,"^",2) ,";",2)
  25695   "RTN","VPR ROS2",208, 0)
  25696    .. S VPRL AB=""
  25697   "RTN","VPR ROS2",209, 0)
  25698    .. I VPRT AG["SC(" S  VPRLAB="C LIN"
  25699   "RTN","VPR ROS2",210, 0)
  25700    .. I VPRT AG["DIC(42 " S VPRLAB ="WARD"
  25701   "RTN","VPR ROS2",211, 0)
  25702    .. I VPRT AG["DPT" S  VPRLAB="P AT"
  25703   "RTN","VPR ROS2",212, 0)
  25704    .. I VPRT AG["SCTM"  S VPRLAB=" PCMM"
  25705   "RTN","VPR ROS2",213, 0)
  25706    .. I VPRT AG["OR(100 .21" S VPR LAB="CPRS"
  25707   "RTN","VPR ROS2",214, 0)
  25708    .. I VPRT AG["VPROST ER" S VPRL AB="ROST"
  25709   "RTN","VPR ROS2",215, 0)
  25710    .. I VPRT AG["DIC(45 .7" S VPRL AB="SPEC"
  25711   "RTN","VPR ROS2",216, 0)
  25712    .. I VPRT AG["VA(200 " S VPRLAB ="PROV"
  25713   "RTN","VPR ROS2",217, 0)
  25714    .. I VPRT AG["PXRM(8 10.4," S V PRLAB="PXR M"
  25715   "RTN","VPR ROS2",218, 0)
  25716    .. I VPRL AB="" S VP ERR="1^INV ALID FILE  TYPE" Q
  25717   "RTN","VPR ROS2",219, 0)
  25718    .. D @VPR LAB
  25719   "RTN","VPR ROS2",220, 0)
  25720    .. S VPRL AB=$S(VPRO P=0:"UNION ",VPROP=1: "INTER",1: "DIFF")
  25721   "RTN","VPR ROS2",221, 0)
  25722    .. D @VPR LAB
  25723   "RTN","VPR ROS2",222, 0)
  25724    . D FORMA T
  25725   "RTN","VPR ROS2",223, 0)
  25726    . I $O(VP RLIST(0))' >0 S VPERR ="1^EMPTY  ROSTER",@V PR@(1)=VPE RR Q
  25727   "RTN","VPR ROS2",224, 0)
  25728    . D ENROS ^VPRFPTC(. ZZ,VPRLIST ) ;added 5 /17/12 grr  to check  patient se nsitivity
  25729   "RTN","VPR ROS2",225, 0)
  25730    . I $D(VP ROUT) K VP ROUT M @VP R=VPRLIST  Q
  25731   "RTN","VPR ROS2",226, 0)
  25732    S VPRTEXT ="</result s>" D ADD( VPRTEXT)
  25733   "RTN","VPR ROS2",227, 0)
  25734    Q
  25735   "RTN","VPR ROS2",228, 0)
  25736    ;;
  25737   "RTN","VPR ROS2",229, 0)
  25738   FORMAT ;;
  25739   "RTN","VPR ROS2",230, 0)
  25740    D ADD("<p atients>")
  25741   "RTN","VPR ROS2",231, 0)
  25742    K VPRII S  VPRII=0 F   S VPRII= $O(VPRLIST (VPRII)) Q :VPRII'>0   D
  25743   "RTN","VPR ROS2",232, 0)
  25744    . N VPRY
  25745   "RTN","VPR ROS2",233, 0)
  25746    . S DFN=V PRII,VPRY= ^DPT(DFN,0 )
  25747   "RTN","VPR ROS2",234, 0)
  25748    . S ICN=$ $GETICN^MP IF001(DFN)
  25749   "RTN","VPR ROS2",235, 0)
  25750    . S NAME= $P(VPRY,"^ ",1),GENDE R=$P(VPRY, "^",2),DOB =$P(VPRY," ^",3),VPRD OB=$$FMTHL 7^XLFDT(DO B),SSN=$P( VPRY,"^",9 )
  25751   "RTN","VPR ROS2",236, 0)
  25752    . S Y="<p atient nam e='"_NAME_ "' gender= '"_GENDER_ "' dob='"_ VPRDOB_"'  ssn='"_SSN _"' id='"_ DFN_$S(ICN :"' icn='" _ICN,1:"") _"' />" D  ADD(Y)
  25753   "RTN","VPR ROS2",237, 0)
  25754    D ADD("</ patients>" )
  25755   "RTN","VPR ROS2",238, 0)
  25756    D ADD("</ roster>")
  25757   "RTN","VPR ROS2",239, 0)
  25758    K Y
  25759   "RTN","VPR ROS2",240, 0)
  25760    Q
  25761   "RTN","VPR ROS2",241, 0)
  25762    ;;
  25763   "RTN","VPR ROS3")
  25764   0^14^B8668 4006
  25765   "RTN","VPR ROS3",1,0)
  25766   VPRROS3 ;S LC/GRR --  Roster Man agement ;4 /24/2012
  25767   "RTN","VPR ROS3",2,0)
  25768    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;AUG  17, 2011;B uild 283
  25769   "RTN","VPR ROS3",3,0)
  25770   PREVIEW(VP R,VPRARRAY ) ;; Previ ews what a  roster wo uld look l ike as def ined
  25771   "RTN","VPR ROS3",4,0)
  25772    ;;  Calle d by the G UI Roster  Builder
  25773   "RTN","VPR ROS3",5,0)
  25774    ;; Input  - VPRARRAY  - contain s roster d ata entere d thru GUI
  25775   "RTN","VPR ROS3",6,0)
  25776    K VPRLIST ,VPRLIST2
  25777   "RTN","VPR ROS3",7,0)
  25778    N %,BEG,D A,DIDEL,DI E,DOB,SSN, DR,END,GEN DER,ICN,NA ME,VPRC,VP RCIEN,VPRD IS,VPRDNAM E,VPRDOB,V PRDT,VPRII I,VPRLIEN, VPROIEN,VP ROWNID
  25779   "RTN","VPR ROS3",8,0)
  25780    N VPROWNN M,VPRPAT,V PRPIEN,VPR PNME,VPRRC NT,VPRRID, VPRTEXT,VP RTIEN,VPRL ST,VPRVAR, VPRVER,VPR WIEN,VPRWN AME,VPRZ,X ,Y
  25781   "RTN","VPR ROS3",9,0)
  25782    N VPRFILT ,VPRI,VPRN LIST,VPRSR CID,VPRTAG ,VPRTLST,V PRY,VPRTYP E,ZZ
  25783   "RTN","VPR ROS3",10,0 )
  25784    N VPRSYS  S VPRSYS=$ $GET^XPAR( "SYS","VPR  SYSTEM NA ME")
  25785   "RTN","VPR ROS3",11,0 )
  25786    S (VPRLIS T,VPRFILT, VPRTYPE,VP ROP,VPRLIS T2,VPERR)= "",VPRI=0
  25787   "RTN","VPR ROS3",12,0 )
  25788    S VPR=$NA (^TMP($J," VPROSTER") ) ; kcm --  moved thi s here so  VPR gets d efined
  25789   "RTN","VPR ROS3",13,0 )
  25790    K ^TMP($J ,"VPROSTER ")
  25791   "RTN","VPR ROS3",14,0 )
  25792    I $O(VPRA RRAY(""))= "" S @VPR@ (1)="0^No  roster dat a passed"  Q
  25793   "RTN","VPR ROS3",15,0 )
  25794    Q:'$$VALI DATE
  25795   "RTN","VPR ROS3",16,0 )
  25796    D NOW^%DT C S VPRDT= %
  25797   "RTN","VPR ROS3",17,0 )
  25798    S VPRZ=""  S VPRZ=$O (VPRARRAY( VPRZ)) I V PRZ="" Q
  25799   "RTN","VPR ROS3",18,0 )
  25800    S VPRNLIS T=""
  25801   "RTN","VPR ROS3",19,0 )
  25802    S VPRRNAM E=$P(VPRAR RAY(VPRZ), "^",1),VPR RNAME=$$ES C^VPRD(VPR RNAME)
  25803   "RTN","VPR ROS3",20,0 )
  25804    S VPRDNAM E=$P(VPRAR RAY(VPRZ), "^",3),VPR DNAME=$$ES C^VPRD(VPR DNAME)
  25805   "RTN","VPR ROS3",21,0 )
  25806    S VPRDIS= $P(VPRARRA Y(VPRZ),"^ ",4)
  25807   "RTN","VPR ROS3",22,0 )
  25808    S VPROWNI D=$P(VPRAR RAY(VPRZ), "^",5)
  25809   "RTN","VPR ROS3",23,0 )
  25810    S VPROWNN M=$P($G(^V A(200,VPRO WNID,0))," ^",1),VPRO WNNM=$$ESC ^VPRD(VPRO WNNM)
  25811   "RTN","VPR ROS3",24,0 )
  25812    F  S VPRZ =$O(VPRARR AY(VPRZ))  Q:VPRZ=""   D
  25813   "RTN","VPR ROS3",25,0 )
  25814    . S VPRY= VPRARRAY(V PRZ)
  25815   "RTN","VPR ROS3",26,0 )
  25816    . S VPROP =$P(VPRY," ^",2)
  25817   "RTN","VPR ROS3",27,0 )
  25818    . S VPRTA G=$P(VPRY, "^",1)
  25819   "RTN","VPR ROS3",28,0 )
  25820    . S VPRLA B=""
  25821   "RTN","VPR ROS3",29,0 )
  25822    . I VPRTA G["Clinic"  S VPRLAB= "CLIN"
  25823   "RTN","VPR ROS3",30,0 )
  25824    . I VPRTA G["Ward" S  VPRLAB="W ARD"
  25825   "RTN","VPR ROS3",31,0 )
  25826    . I VPRTA G["Patient " S VPRLAB ="PAT"
  25827   "RTN","VPR ROS3",32,0 )
  25828    . I VPRTA G["PCMM Te am" S VPRL AB="PCMM"
  25829   "RTN","VPR ROS3",33,0 )
  25830    . I VPRTA G["OE/RR"  S VPRLAB=" CPRS"
  25831   "RTN","VPR ROS3",34,0 )
  25832    . I VPRTA G["VPR Ros ter" S VPR LAB="ROST"
  25833   "RTN","VPR ROS3",35,0 )
  25834    . I VPRTA G["Special ty" S VPRL AB="SPEC"
  25835   "RTN","VPR ROS3",36,0 )
  25836    . I VPRTA G["Provide r" S VPRLA B="PROV"
  25837   "RTN","VPR ROS3",37,0 )
  25838    . I VPRTA G["PXRM" S  VPRLAB="P XRM"
  25839   "RTN","VPR ROS3",38,0 )
  25840    . I VPRLA B="" S @VP R@(1)="1^I NVALID FIL E TYPE" Q
  25841   "RTN","VPR ROS3",39,0 )
  25842    . D @VPRL AB
  25843   "RTN","VPR ROS3",40,0 )
  25844    . S VPRLA B=$S(VPROP ="UNION":" UNION",VPR OP="Inters ection":"I NTER",1:"D IFF")
  25845   "RTN","VPR ROS3",41,0 )
  25846    . S VPRNL IST=""
  25847   "RTN","VPR ROS3",42,0 )
  25848    . D @VPRL AB
  25849   "RTN","VPR ROS3",43,0 )
  25850    I $D(VPRO UT) K VPRO UT M VPRLI ST2=VPRLIS T Q
  25851   "RTN","VPR ROS3",44,0 )
  25852    I $O(VPRL IST(0))'>0  S @VPR@(1 )="1^EMPTY  ROSTER" Q
  25853   "RTN","VPR ROS3",45,0 )
  25854    D SEND
  25855   "RTN","VPR ROS3",46,0 )
  25856    D ENROS^V PRFPTC(.ZZ ,VPRLIST)  ;added 5/1 7/12 grr t o check pa tient sens itivity
  25857   "RTN","VPR ROS3",47,0 )
  25858    Q
  25859   "RTN","VPR ROS3",48,0 )
  25860    ;
  25861   "RTN","VPR ROS3",49,0 )
  25862   CLIN ;Proc ess patien ts for thi s clinic.   Select al l if filte r is null
  25863   "RTN","VPR ROS3",50,0 )
  25864    K VPRLIST 2,VPROUT S  VPRLIST2= ""
  25865   "RTN","VPR ROS3",51,0 )
  25866    I '$D(DT)  S DT=$$DT ^XLFDT()
  25867   "RTN","VPR ROS3",52,0 )
  25868    S BEG=DT, END=$S(VPR FILT="T":D T+.24,1:99 99999+.24) ,VPRIII=BE G
  25869   "RTN","VPR ROS3",53,0 )
  25870    S VPRCIEN =+$P(VPRY, "^",3) F   S VPRIII=$ O(^SC(VPRC IEN,"S",VP RIII)) Q:V PRIII'>0!( VPRIII>END )  D
  25871   "RTN","VPR ROS3",54,0 )
  25872    . S VPRII =0 F  S VP RII=$O(^SC (VPRCIEN," S",VPRIII, 1,VPRII))  Q:VPRII'>0   S DFN=$P ($G(^SC(VP RCIEN,"S", VPRIII,1,V PRII,0))," ^",1) I DF N>0 D
  25873   "RTN","VPR ROS3",55,0 )
  25874    . .S VPRL IST2(DFN)= ""
  25875   "RTN","VPR ROS3",56,0 )
  25876    Q
  25877   "RTN","VPR ROS3",57,0 )
  25878    ;
  25879   "RTN","VPR ROS3",58,0 )
  25880   WARD ;Proc ess patien ts for thi s ward
  25881   "RTN","VPR ROS3",59,0 )
  25882    K VPRLIST 2,VPROUT S  VPRLIST2= ""
  25883   "RTN","VPR ROS3",60,0 )
  25884    S VPRWIEN =+$P(VPRY, "^",3),VPR WNAME=$P($ G(^DIC(42, VPRWIEN,0) ),"^",1)
  25885   "RTN","VPR ROS3",61,0 )
  25886    S VPRIII= 0 F  S VPR III=$O(^DG PM("CN",VP RWNAME,VPR III)) Q:VP RIII'>0  D
  25887   "RTN","VPR ROS3",62,0 )
  25888    . S DFN=$ P($G(^DGPM (VPRIII,0) ),"^",3),V PRLIST2(DF N)=""
  25889   "RTN","VPR ROS3",63,0 )
  25890    Q
  25891   "RTN","VPR ROS3",64,0 )
  25892    ;
  25893   "RTN","VPR ROS3",65,0 )
  25894   PAT ;Proce ss patient  from Pati ent file S ource
  25895   "RTN","VPR ROS3",66,0 )
  25896    K VPRLIST 2,VPROUT S  VPRLIST2= ""
  25897   "RTN","VPR ROS3",67,0 )
  25898    S DFN=+$P (VPRY,"^", 3),VPRLIST 2(DFN)=""
  25899   "RTN","VPR ROS3",68,0 )
  25900    Q
  25901   "RTN","VPR ROS3",69,0 )
  25902    ;
  25903   "RTN","VPR ROS3",70,0 )
  25904   PCMM ;Proc ess patien ts from a  PCMM team
  25905   "RTN","VPR ROS3",71,0 )
  25906    K VPRLIST 2,VPROUT S  VPRLIST2= ""
  25907   "RTN","VPR ROS3",72,0 )
  25908    S VPRTIEN =+$P(VPRY, "^",3),VPE RR="",VPRT LST=""
  25909   "RTN","VPR ROS3",73,0 )
  25910    D PTTM^SC APMC(VPRTI EN,,"VPRTL ST",VPERR)
  25911   "RTN","VPR ROS3",74,0 )
  25912    S VPRIII= "" F  S VP RIII=$O(VP RTLST(VPRI II)) Q:VPR III'>0  S  DFN=$P(VPR TLST(VPRII I),"^",1)  S VPRLIST2 (DFN)=""
  25913   "RTN","VPR ROS3",75,0 )
  25914    Q
  25915   "RTN","VPR ROS3",76,0 )
  25916    ;
  25917   "RTN","VPR ROS3",77,0 )
  25918   CPRS ;Proc ess patien ts from CP RS Lists
  25919   "RTN","VPR ROS3",78,0 )
  25920    K VPRLIST 2,VPROUT S  VPRLIST2= ""
  25921   "RTN","VPR ROS3",79,0 )
  25922    S VPROIEN =+$P(VPRY, "^",3),VPE RR=""
  25923   "RTN","VPR ROS3",80,0 )
  25924    S VPRIII= 0 F  S VPR III=$O(^OR (100.21,VP ROIEN,10,V PRIII)) Q: VPRIII'>0   S DFN=$P( ^OR(100.21 ,VPROIEN,1 0,VPRIII,0 ),";",1) S  VPRLIST2( DFN)=""
  25925   "RTN","VPR ROS3",81,0 )
  25926    Q
  25927   "RTN","VPR ROS3",82,0 )
  25928    ;
  25929   "RTN","VPR ROS3",83,0 )
  25930   ROST ;Proc ess patien ts from se lected ros ter
  25931   "RTN","VPR ROS3",84,0 )
  25932    N VPR,VPR IEN,VPERR
  25933   "RTN","VPR ROS3",85,0 )
  25934    S VPRIEN= +$P(VPRY," ^",3),VPER R="",VPROU T=1
  25935   "RTN","VPR ROS3",86,0 )
  25936    D COMPILE ^VPRROS2(. VPR,VPRIEN ,"")
  25937   "RTN","VPR ROS3",87,0 )
  25938    M VPRLIST =VPRLIST2
  25939   "RTN","VPR ROS3",88,0 )
  25940    K VPROUT
  25941   "RTN","VPR ROS3",89,0 )
  25942    Q
  25943   "RTN","VPR ROS3",90,0 )
  25944    ;
  25945   "RTN","VPR ROS3",91,0 )
  25946   SPEC ;Proc ess patien ts with se lected Tre ating Spec ialty
  25947   "RTN","VPR ROS3",92,0 )
  25948    K VPRLIST 2,VPROUT S  VPRLIST2= ""
  25949   "RTN","VPR ROS3",93,0 )
  25950    S VPROIEN =+$P(VPRY, "^",3),VPE RR=""
  25951   "RTN","VPR ROS3",94,0 )
  25952    N DFN S D FN=0 F  S  DFN=$O(^DP T("ATR",VP ROIEN,DFN) ) Q:DFN'>0   S VPRLIS T2(DFN)=""
  25953   "RTN","VPR ROS3",95,0 )
  25954    Q
  25955   "RTN","VPR ROS3",96,0 )
  25956    ;
  25957   "RTN","VPR ROS3",97,0 )
  25958   PROV ;Proc ess patien ts for sel ected prov ider
  25959   "RTN","VPR ROS3",98,0 )
  25960    K VPRLIST 2,VPROUT S  VPRLIST2= ""
  25961   "RTN","VPR ROS3",99,0 )
  25962    S VPRPIEN =+$P(VPRY, "^",3),VPE RR=""
  25963   "RTN","VPR ROS3",100, 0)
  25964    N DFN S D FN=0 F  S  DFN=$O(^DP T("APR",VP RPIEN,DFN) ) Q:DFN'>0   S VPRLIS T2(DFN)=""
  25965   "RTN","VPR ROS3",101, 0)
  25966    Q
  25967   "RTN","VPR ROS3",102, 0)
  25968    ;
  25969   "RTN","VPR ROS3",103, 0)
  25970   PXRM ;Proc ess patien ts for sel ected pane l
  25971   "RTN","VPR ROS3",104, 0)
  25972    K VPRLIST 2,VPROUT,V PRPAT,VPRR IEN S VPRL IST2=""
  25973   "RTN","VPR ROS3",105, 0)
  25974    S VPRPIEN =+$P(VPRY, "^",3),VPE RR="",VPRL IEN=$P($G( ^PXRM(810. 4,VPRPIEN, 0)),"^",1)  I VPRLIEN ="" S @VPR @(1)="Inva lid PXRM"  Q
  25975   "RTN","VPR ROS3",106, 0)
  25976    ;S VPRRIE N=$O(^VPRO STER("B",V PRRNAME,"" )) I VPRRI EN'>0 S @V PR@(1)="In valid PXRM " Q
  25977   "RTN","VPR ROS3",107, 0)
  25978    ;S VPRPNM E=$P(^VPRO STER(VPRRI EN,0),"^", 6)
  25979   "RTN","VPR ROS3",108, 0)
  25980    S VPRC=VP RPIEN
  25981   "RTN","VPR ROS3",109, 0)
  25982    S VPRPAT= "" D RUNLI ST^VPRROS5 (.VPRPAT,V PRPIEN,VPR RNAME,0,1)
  25983   "RTN","VPR ROS3",110, 0)
  25984    S VPRII=0  F  S VPRI I=$O(VPRPA T(VPRC,VPR II)) Q:VPR II'>0  S D FN=VPRPAT( VPRC,VPRII ),VPRLIST2 (DFN)=""
  25985   "RTN","VPR ROS3",111, 0)
  25986    Q
  25987   "RTN","VPR ROS3",112, 0)
  25988    ;
  25989   "RTN","VPR ROS3",113, 0)
  25990   UNION ;Add  to existi ng list
  25991   "RTN","VPR ROS3",114, 0)
  25992    S VPRII=0  F  S VPRI I=$O(VPRLI ST2(VPRII) ) Q:VPRII' >0  S VPRL IST(VPRII) =""
  25993   "RTN","VPR ROS3",115, 0)
  25994    Q
  25995   "RTN","VPR ROS3",116, 0)
  25996    ;
  25997   "RTN","VPR ROS3",117, 0)
  25998   INTER ;Int ersect wit h existing  list
  25999   "RTN","VPR ROS3",118, 0)
  26000    S VPRII=0  F  S VPRI I=$O(VPRLI ST(VPRII))  Q:VPRII'> 0  D
  26001   "RTN","VPR ROS3",119, 0)
  26002    . I '$D(V PRLIST2(VP RII)) K VP RLIST(VPRI I)
  26003   "RTN","VPR ROS3",120, 0)
  26004    Q
  26005   "RTN","VPR ROS3",121, 0)
  26006    ;
  26007   "RTN","VPR ROS3",122, 0)
  26008   DIFF ;Remo ve patient s from thi s source t hat we hav e so far o r add new  one
  26009   "RTN","VPR ROS3",123, 0)
  26010    S VPRII=0  F  S VPRI I=$O(VPRLI ST2(VPRII) ) Q:VPRII' >0  D
  26011   "RTN","VPR ROS3",124, 0)
  26012    . I '$D(V PRLIST(VPR II)) S VPR LIST(VPRII )=""
  26013   "RTN","VPR ROS3",125, 0)
  26014    . E  K VP RLIST(VPRI I)
  26015   "RTN","VPR ROS3",126, 0)
  26016    Q
  26017   "RTN","VPR ROS3",127, 0)
  26018    ;
  26019   "RTN","VPR ROS3",128, 0)
  26020   SEND ;send  pending r osters.  C alled thro ugh RPC
  26021   "RTN","VPR ROS3",129, 0)
  26022    S VPRRCNT =0,VPRI=0, VPRII=0
  26023   "RTN","VPR ROS3",130, 0)
  26024    S VPRVER= "<results  version='" _$P($T(VPR ROS3+1),"; ",3)_"'>"
  26025   "RTN","VPR ROS3",131, 0)
  26026    D ADD(VPR VER)
  26027   "RTN","VPR ROS3",132, 0)
  26028    ;S VPRRNA ME=$P(^VPR OSTER(VPRI EN,0),"^", 1),VPRDNAM E=$P(^VPRO STER(VPRIE N,0),"^",2 )
  26029   "RTN","VPR ROS3",133, 0)
  26030    S VPRTEXT ="<roster  ien='' own ername='"_ VPROWNNM_" '  ownerid ='"_VPROWN ID_"'>" D  ADD(VPRTEX T)
  26031   "RTN","VPR ROS3",134, 0)
  26032    S VPRTEXT ="<rosterN ame>"_VPRR NAME_"</ro sterName>"  D ADD(VPR TEXT)
  26033   "RTN","VPR ROS3",135, 0)
  26034    S VPRTEXT ="<display Name>"_VPR DNAME_"</d isplayName >" D ADD(V PRTEXT)
  26035   "RTN","VPR ROS3",136, 0)
  26036    D ADD("<p atients>")
  26037   "RTN","VPR ROS3",137, 0)
  26038    K VPRII S  VPRII=0 F   S VPRII= $O(VPRLIST (VPRII)) Q :VPRII'>0   D 
  26039   "RTN","VPR ROS3",138, 0)
  26040    . S DFN=V PRII
  26041   "RTN","VPR ROS3",139, 0)
  26042    . S ICN=$ $GETICN^MP IF001(DFN)
  26043   "RTN","VPR ROS3",140, 0)
  26044    . S NAME= $P(^DPT(DF N,0),"^",1 ),GENDER=$ P(^DPT(DFN ,0),"^",2) ,SSN=$P(^D PT(DFN,0), "^",9),DOB =$P(^DPT(D FN,0),"^", 3),VPRDOB= $$FMTHL7^X LFDT(DOB)
  26045   "RTN","VPR ROS3",141, 0)
  26046    . S Y="<p atient nam e='"_NAME_ "' gender= '"_GENDER_ "' dob='"_ VPRDOB_"'  ssn='"_SSN _"' id='"_ DFN_$S(ICN :"' icn='" _ICN,1:"") _"' />" D  ADD(Y)
  26047   "RTN","VPR ROS3",142, 0)
  26048    D ADD("</ patients>" )
  26049   "RTN","VPR ROS3",143, 0)
  26050    D ADD("</ roster>")
  26051   "RTN","VPR ROS3",144, 0)
  26052    S VPRTEXT ="</result s>" D ADD( VPRTEXT)
  26053   "RTN","VPR ROS3",145, 0)
  26054    Q
  26055   "RTN","VPR ROS3",146, 0)
  26056    ;
  26057   "RTN","VPR ROS3",147, 0)
  26058    ;
  26059   "RTN","VPR ROS3",148, 0)
  26060   ADD(X) ; - - Add a li ne @VPR@(n )=X
  26061   "RTN","VPR ROS3",149, 0)
  26062    S VPRI=$G (VPRI)+1
  26063   "RTN","VPR ROS3",150, 0)
  26064    S @VPR@(V PRI)=X
  26065   "RTN","VPR ROS3",151, 0)
  26066    Q
  26067   "RTN","VPR ROS3",152, 0)
  26068    ;
  26069   "RTN","VPR ROS3",153, 0)
  26070   UPDATE(VPR ,VPRARRAY)  ;;Update  Roster dat a with dat a from GUI
  26071   "RTN","VPR ROS3",154, 0)
  26072    N VPRZ,VP RRNAME,VPR ID,VPRDNAM E,VPRDIS,V PRRID,FDA, VPROWNID,V PRSRCID,VP ROP,VPRSRC NM,VPRLAB, VPRVAR,BEF ORE,AFTER
  26073   "RTN","VPR ROS3",155, 0)
  26074    N VPRSYS  S VPRSYS=$ $GET^XPAR( "SYS","VPR  SYSTEM NA ME")
  26075   "RTN","VPR ROS3",156, 0)
  26076    S VPR=$NA (^TMP($J," VPROSTER") )
  26077   "RTN","VPR ROS3",157, 0)
  26078    Q:'$$VALI DATE
  26079   "RTN","VPR ROS3",158, 0)
  26080    D NOW^%DT C S VPRDT= % ;added 5 /11/12 grr  for traci ng
  26081   "RTN","VPR ROS3",159, 0)
  26082    S VPRZ=""  S VPRZ=$O (VPRARRAY( VPRZ)) Q:V PRZ=""
  26083   "RTN","VPR ROS3",160, 0)
  26084    S VPRRNAM E=$P(VPRAR RAY(VPRZ), "^",1),VPR RID=$P(VPR ARRAY(VPRZ ),"^",2),V PRDNAME=$P (VPRARRAY( VPRZ),"^", 3),VPRDIS= $P(VPRARRA Y(VPRZ),"^ ",4),VPROW NID=$P(VPR ARRAY(VPRZ ),"^",5)
  26085   "RTN","VPR ROS3",161, 0)
  26086    D:VPRRID> 0 BEFORE
  26087   "RTN","VPR ROS3",162, 0)
  26088    I VPRRID= "" D ADDRO S
  26089   "RTN","VPR ROS3",163, 0)
  26090    I '$D(^VP ROSTER(VPR RID,0)) S  @VPR@(1)=" RosterID p assed was  invalid" Q
  26091   "RTN","VPR ROS3",164, 0)
  26092    S FDA(1,5 61.2,""_VP RRID_","_" ",.01)=VPR RNAME
  26093   "RTN","VPR ROS3",165, 0)
  26094    S FDA(1,5 61.2,""_VP RRID_","_" ",.02)=VPR DNAME
  26095   "RTN","VPR ROS3",166, 0)
  26096    S FDA(1,5 61.2,""_VP RRID_","_" ",.03)=VPR DIS
  26097   "RTN","VPR ROS3",167, 0)
  26098    S FDA(1,5 61.2,""_VP RRID_","_" ",.04)=VPR OWNID
  26099   "RTN","VPR ROS3",168, 0)
  26100    S FDA(1,5 61.2,""_VP RRID_","_" ",99)=VPRD T
  26101   "RTN","VPR ROS3",169, 0)
  26102    D UPDATE^ DIE("","FD A(1)")
  26103   "RTN","VPR ROS3",170, 0)
  26104    K ^VPROST ER(VPRRID, 1),FDA
  26105   "RTN","VPR ROS3",171, 0)
  26106    F  S VPRZ =$O(VPRARR AY(VPRZ))  Q:VPRZ=""   D
  26107   "RTN","VPR ROS3",172, 0)
  26108    . S VPRY= VPRARRAY(V PRZ)
  26109   "RTN","VPR ROS3",173, 0)
  26110    . S VPRSR CID=$P(VPR Y,"^",3)
  26111   "RTN","VPR ROS3",174, 0)
  26112    . S VPROP =$P(VPRY," ^",2)
  26113   "RTN","VPR ROS3",175, 0)
  26114    . S VPRSR CNM=$$UP^X LFSTR($P(V PRY,"^",1) )
  26115   "RTN","VPR ROS3",176, 0)
  26116    . S VPRLA B=""
  26117   "RTN","VPR ROS3",177, 0)
  26118    . I VPRSR CNM["CLINI C" S VPRVA R="SC("
  26119   "RTN","VPR ROS3",178, 0)
  26120    . I VPRSR CNM["WARD"  S VPRVAR= "DIC(42,"
  26121   "RTN","VPR ROS3",179, 0)
  26122    . I VPRSR CNM["PATIE NT" S VPRV AR="DPT("
  26123   "RTN","VPR ROS3",180, 0)
  26124    . I VPRSR CNM["PCMM  TEAM" S VP RVAR="SCTM (404.51,"
  26125   "RTN","VPR ROS3",181, 0)
  26126    . I VPRSR CNM["OE/RR " S VPRVAR ="OR(100.2 1,"
  26127   "RTN","VPR ROS3",182, 0)
  26128    . I VPRSR CNM["VPR R OSTER" S V PRVAR="VPR OSTER("
  26129   "RTN","VPR ROS3",183, 0)
  26130    . I VPRSR CNM["SPECI ALTY" S VP RVAR="DIC( 45.7,"
  26131   "RTN","VPR ROS3",184, 0)
  26132    . I VPRSR CNM["PROVI DER" S VPR VAR="VA(20 0,"
  26133   "RTN","VPR ROS3",185, 0)
  26134    . I VPRSR CNM["PXRM"  S VPRVAR= "PXRM(810. 4,"
  26135   "RTN","VPR ROS3",186, 0)
  26136    . S FDA(1 ,561.21,"+ 1,"_VPRRID _",",.01)= VPRZ
  26137   "RTN","VPR ROS3",187, 0)
  26138    . S FDA(1 ,561.21,"+ 1,"_VPRRID _",",.02)= VPRSRCID_" ;"_VPRVAR
  26139   "RTN","VPR ROS3",188, 0)
  26140    . S FDA(1 ,561.21,"+ 1,"_VPRRID _",",.03)= $S(VPROP=" UNION":0,V PROP="INTE RSECTION": 1,1:2)
  26141   "RTN","VPR ROS3",189, 0)
  26142    . I VPRSR CNM="PXRM"  S FDA(1,5 61.21,"+1, "_VPRRID_" ,",.06)="U PDATE TEST  HMP ROSTE R"
  26143   "RTN","VPR ROS3",190, 0)
  26144    . D UPDAT E^DIE(""," FDA(1)")
  26145   "RTN","VPR ROS3",191, 0)
  26146    ;D GET^VP RROS6(VPRR ID)
  26147   "RTN","VPR ROS3",192, 0)
  26148    S FILTER( "domain")= "roster",F ILTER("id" )=VPRRID
  26149   "RTN","VPR ROS3",193, 0)
  26150    D GET^VPR EF(.VPR,.F ILTER)
  26151   "RTN","VPR ROS3",194, 0)
  26152    S RESULT= $$COMPARE( .BEFORE,.A FTER)
  26153   "RTN","VPR ROS3",195, 0)
  26154    I RESULT= 1 D POSTX^ VPREVNT("r oster",VPR RID) ;if R ESULT is 1  means ros ter has ch anged
  26155   "RTN","VPR ROS3",196, 0)
  26156    Q
  26157   "RTN","VPR ROS3",197, 0)
  26158    ;
  26159   "RTN","VPR ROS3",198, 0)
  26160   ADDROS ;
  26161   "RTN","VPR ROS3",199, 0)
  26162    N DIC,DLA YGO,X,Y
  26163   "RTN","VPR ROS3",200, 0)
  26164    S DIC="^V PROSTER(", DIC(0)="LQ ",DLAYGO=5 61.2,X=VPR RNAME D ^D IC S VPRRI D=+Y
  26165   "RTN","VPR ROS3",201, 0)
  26166    Q
  26167   "RTN","VPR ROS3",202, 0)
  26168    ;
  26169   "RTN","VPR ROS3",203, 0)
  26170   DELROS(VPR ,VPRIEN) ;
  26171   "RTN","VPR ROS3",204, 0)
  26172    S HDUZ(0) =DUZ(0),DU Z(0)="@",D IK="^VPROS TER(",DA=V PRIEN,DIDE L=1 D ^DIK  S DUZ(0)= HDUZ(0),VP R="Roster  Deleted!"
  26173   "RTN","VPR ROS3",205, 0)
  26174    K HDUZ,DI K,DIDEL
  26175   "RTN","VPR ROS3",206, 0)
  26176    Q
  26177   "RTN","VPR ROS3",207, 0)
  26178    ;
  26179   "RTN","VPR ROS3",208, 0)
  26180   COMPARE(OL D,NEW) ;
  26181   "RTN","VPR ROS3",209, 0)
  26182    N VPRII,D IFF
  26183   "RTN","VPR ROS3",210, 0)
  26184    S VPRII=0  F  S VPRI I=$O(OLD(V PRII)) Q:V PRII'>0  D
  26185   "RTN","VPR ROS3",211, 0)
  26186    . I '$D(N EW(VPRII))  S NEW(VPR II)=""
  26187   "RTN","VPR ROS3",212, 0)
  26188    . E  K NE W(VPRII)
  26189   "RTN","VPR ROS3",213, 0)
  26190    S DIFF=$S ($O(NEW(0) )'>0:0,1:1 )
  26191   "RTN","VPR ROS3",214, 0)
  26192    Q DIFF
  26193   "RTN","VPR ROS3",215, 0)
  26194    ;
  26195   "RTN","VPR ROS3",216, 0)
  26196   VALIDATE()  ;Will ver ify VPRARR AY entries  are all v alid
  26197   "RTN","VPR ROS3",217, 0)
  26198    N I,OUT,O K
  26199   "RTN","VPR ROS3",218, 0)
  26200    S I="",OK =0,OUT=0
  26201   "RTN","VPR ROS3",219, 0)
  26202    F  S I=$O (VPRARRAY( I)) Q:I=""   D  Q:OUT
  26203   "RTN","VPR ROS3",220, 0)
  26204    . I $L(VP RARRAY(I), "^")'=5&($ L(VPRARRAY (I),"^")'= 3) S @VPR@ (1)="Param eter forma t invalid:  "_VPRARRA Y(I) S OK= 0,OUT=1 Q
  26205   "RTN","VPR ROS3",221, 0)
  26206    . I $L(VP RARRAY(I), "^")=3 D   Q:OUT
  26207   "RTN","VPR ROS3",222, 0)
  26208    . . I $P( VPRARRAY(I ),"^",2)=" UNION"!($P (VPRARRAY( I),"^",2)= "INTERSECT ION")!($P( VPRARRAY(I ),"^",2)=" DIFFERENCE ") S OK=1, OUT=0
  26209   "RTN","VPR ROS3",223, 0)
  26210    . . E  S  OK=0,OUT=1 ,@VPR@(1)= "Parameter  format in valid: "_V PRARRAY(I)  Q
  26211   "RTN","VPR ROS3",224, 0)
  26212    . . I $P( VPRARRAY(I ),"^",3)>0  S OK=1,OU T=0
  26213   "RTN","VPR ROS3",225, 0)
  26214    . . E  S  OK=0,OUT=1 ,@VPR@(1)= "Parameter  format in valid: "_V PRARRAY(I)  Q
  26215   "RTN","VPR ROS3",226, 0)
  26216    Q OK
  26217   "RTN","VPR ROS3",227, 0)
  26218    ;
  26219   "RTN","VPR ROS3",228, 0)
  26220   BEFORE ;SA VE EXISTIN G ROSTER P ATIENTS
  26221   "RTN","VPR ROS3",229, 0)
  26222    Q:$O(^VPR OSTER(VPRR ID,4,0))'> 0
  26223   "RTN","VPR ROS3",230, 0)
  26224    S I=0 F   S I=$O(^VP ROSTER(VPR RID,4,I))  Q:I'>0  S  DFN=$P(^VP ROSTER(VPR RID,4,I,0) ,"^"),BEFO RE(DFN)=""
  26225   "RTN","VPR ROS3",231, 0)
  26226    Q
  26227   "RTN","VPR ROS3",232, 0)
  26228    ;
  26229   "RTN","VPR ROS3",233, 0)
  26230   TEST ;TEMP ORARY
  26231   "RTN","VPR ROS3",234, 0)
  26232    S VPRARRA Y(0)="AAA  TEST^^aaaa  test^^108 8"
  26233   "RTN","VPR ROS3",235, 0)
  26234    S VPRARRA Y(1)="Pati ent^UNION^ 100846"
  26235   "RTN","VPR ROS3",236, 0)
  26236    S VPRARRA Y(2)="Pati ent^UNION^ 100847"
  26237   "RTN","VPR ROS3",237, 0)
  26238    D UPDATE( .VPR,.VPRA RRAY)
  26239   "RTN","VPR ROS3",238, 0)
  26240    Q
  26241   "RTN","VPR ROS3",239, 0)
  26242   TEST0 ;
  26243   "RTN","VPR ROS3",240, 0)
  26244    S BEFORE( 1)="",BEFO RE(5)="",B EFORE(8)=" ",AFTER(1) ="",AFTER( 5)="",AFTE R(8)=""
  26245   "RTN","VPR ROS3",241, 0)
  26246    S RESULT= $$COMPARE( .BEFORE,.A FTER)
  26247   "RTN","VPR ROS3",242, 0)
  26248    W "RESULT  IS: ",RES ULT
  26249   "RTN","VPR ROS3",243, 0)
  26250    Q
  26251   "RTN","VPR ROS3",244, 0)
  26252    ;
  26253   "RTN","VPR ROS3",245, 0)
  26254   TEST1 ;
  26255   "RTN","VPR ROS3",246, 0)
  26256    S BEFORE( 1)="",BEFO RE(5)="",B EFORE(8)=" ",AFTER(5) ="",AFTER( 8)=""
  26257   "RTN","VPR ROS3",247, 0)
  26258    S RESULT= $$COMPARE( .BEFORE,.A FTER)
  26259   "RTN","VPR ROS3",248, 0)
  26260    W "RESULT  IS: ",RES ULT
  26261   "RTN","VPR ROS3",249, 0)
  26262    Q
  26263   "RTN","VPR ROS3",250, 0)
  26264    ;
  26265   "RTN","VPR ROS4")
  26266   0^15^B9130 2550
  26267   "RTN","VPR ROS4",1,0)
  26268   VPRROS4 ;S LC/GRR --  Roster Man agement
  26269   "RTN","VPR ROS4",2,0)
  26270    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;AUG  17, 2011;B uild 283
  26271   "RTN","VPR ROS4",3,0)
  26272   GETSRC(VPR ,VPRSRC,VP RFILT) ;;  Get Source  data from  requested  source ty pe
  26273   "RTN","VPR ROS4",4,0)
  26274    ;;  For e xample, If  source ty pe is "Cli nic", pass  all clini c names an d id's to  calling GU I
  26275   "RTN","VPR ROS4",5,0)
  26276    ;; Input  - VPRARRAY  - contain s roster d ata entere d thru GUI
  26277   "RTN","VPR ROS4",6,0)
  26278    ;K VPRLIS T,VPRLIST2
  26279   "RTN","VPR ROS4",7,0)
  26280    I '$D(VPR FILT) S VP RFILT=""
  26281   "RTN","VPR ROS4",8,0)
  26282    N VPRLIST ,VPRLIST2, VPRTYPE,VP ERR,VPRI,V PRRNAME,VP RY,VPROP,V PRTAG,VPRL AB,VPRNLIS T,VPRSTN,V PRTEXT,VPR VER,Y,ACT, CHK,CSNM
  26283   "RTN","VPR ROS4",9,0)
  26284    N CSNUM,C SP,IDNAME, IDVALUE,TY PENM,UPNAM E,VDATE,VP RACT,VPRDA TA,VPRDIVP ,VPRNAME,V PRCNT,VPRR CNT,ACTIVE
  26285   "RTN","VPR ROS4",10,0 )
  26286    N VPRSYS  S VPRSYS=$ $GET^XPAR( "SYS","VPR  SYSTEM NA ME")
  26287   "RTN","VPR ROS4",11,0 )
  26288    S (VPRLIS T,VPRTYPE, VPROP,VPRL IST2,VPERR )="",VPRI= 0
  26289   "RTN","VPR ROS4",12,0 )
  26290    K ^TMP($J ,"VPROSTER ")
  26291   "RTN","VPR ROS4",13,0 )
  26292    S VPR=$NA (^TMP($J," VPROSTER") )
  26293   "RTN","VPR ROS4",14,0 )
  26294    S VPRACT= "I 1"
  26295   "RTN","VPR ROS4",15,0 )
  26296    I VPRFILT '="" S X=V PRFILT X ^ %ZOSF("UPP ERCASE") S  VPRFILT=Y  S VPRACT= "I UPNAME[ VPRFILT"
  26297   "RTN","VPR ROS4",16,0 )
  26298    I VPRSRC[ "Clinic" S  VPRLAB="C LIN"
  26299   "RTN","VPR ROS4",17,0 )
  26300    I VPRSRC[ "Ward" S V PRLAB="WAR D"
  26301   "RTN","VPR ROS4",18,0 )
  26302    I VPRSRC[ "Patient"  S VPRLAB=" PAT"
  26303   "RTN","VPR ROS4",19,0 )
  26304    I VPRSRC[ "PCMM Team " S VPRLAB ="PCMM"
  26305   "RTN","VPR ROS4",20,0 )
  26306    I VPRSRC[ "OE/RR" S  VPRLAB="CP RS"
  26307   "RTN","VPR ROS4",21,0 )
  26308    I VPRSRC[ "VPR Roste r" S VPRLA B="ROST"
  26309   "RTN","VPR ROS4",22,0 )
  26310    I VPRSRC[ "Specialty " S VPRLAB ="SPEC"
  26311   "RTN","VPR ROS4",23,0 )
  26312    I VPRSRC[ "Provider"  S VPRLAB= "PROV"
  26313   "RTN","VPR ROS4",24,0 )
  26314    I VPRSRC[ "PXRM" S V PRLAB="PXR M"
  26315   "RTN","VPR ROS4",25,0 )
  26316    I VPRLAB= "" S VPERR ="1^INVALI D SOURCE T YPE" Q
  26317   "RTN","VPR ROS4",26,0 )
  26318    D @VPRLAB
  26319   "RTN","VPR ROS4",27,0 )
  26320    D SEND
  26321   "RTN","VPR ROS4",28,0 )
  26322    Q VPR
  26323   "RTN","VPR ROS4",29,0 )
  26324    ;
  26325   "RTN","VPR ROS4",30,0 )
  26326   CLIN ;Proc ess patien ts for thi s clinic.   Select al l if filte r is null
  26327   "RTN","VPR ROS4",31,0 )
  26328    K VPRARRA Y S VPRARR AY=""
  26329   "RTN","VPR ROS4",32,0 )
  26330    S VPRNAME ="" F  S V PRNAME=$O( ^SC("B",VP RNAME)) Q: VPRNAME=""   S X=VPRN AME X ^%ZO SF("UPPERC ASE") S UP NAME=Y X V PRACT I  D
  26331   "RTN","VPR ROS4",33,0 )
  26332    . S VPRI= $O(^SC("B" ,VPRNAME,0 )) I ($P(^ SC(VPRI,0) ,"^",3)="C ")&($$ACTL OC^ORWU(VP RI)) D
  26333   "RTN","VPR ROS4",34,0 )
  26334    . . I $D( ^SC(VPRI," I")) Q:$P( ^("I"),"^" ,2)=""  ;a dded 4/24/ 2013
  26335   "RTN","VPR ROS4",35,0 )
  26336    . . S (CS P,CSNM,CSN UM,SVC,SER VICE,VPRDI V,VPRDIVP) ="" ;added  4/24/2013
  26337   "RTN","VPR ROS4",36,0 )
  26338    . . S CSP =$P(^SC(VP RI,0),"^", 7) I CSP]" " S CSNM=$ P(^DIC(40. 7,CSP,0)," ^",1),CSNU M=$P(^DIC( 40.7,CSP,0 ),"^",2) ; modified 4 /24/2013
  26339   "RTN","VPR ROS4",37,0 )
  26340    . . S VPR DIVP=$P(^S C(VPRI,0), "^",15) I  VPRDIVP]""  S VPRDIV= $P($G(^DG( 40.8,VPRDI VP,0)),"^" ,1) ;modif ied 4/24/2 013
  26341   "RTN","VPR ROS4",38,0 )
  26342    . . S SVC =$P(^SC(VP RI,0),"^", 8),SERVICE =$S(SVC="M ":"MEDICIN E",SVC="S" :"SURGERY" ,SVC="P":" PSYCHIATRY ",SVC="R": "REHAB MED ICINE",SVC ="N":"NEUR OLOGY",1:" NONE")
  26343   "RTN","VPR ROS4",39,0 )
  26344    . . S VPR ARRAY(VPRN AME)=VPRI
  26345   "RTN","VPR ROS4",40,0 )
  26346    . . S VPR ARRAY(VPRN AME,1)="DI VISION"_"^ "_VPRDIV
  26347   "RTN","VPR ROS4",41,0 )
  26348    . . S VPR ARRAY(VPRN AME,2)="CL INIC STOP  NAME"_"^"_ CSNM
  26349   "RTN","VPR ROS4",42,0 )
  26350    . . S VPR ARRAY(VPRN AME,3)="CL INIC STOP  NUMBER"_"^ "_CSNUM
  26351   "RTN","VPR ROS4",43,0 )
  26352    . . S VPR ARRAY(VPRN AME,4)="SE RVICE"_"^" _SERVICE
  26353   "RTN","VPR ROS4",44,0 )
  26354    Q
  26355   "RTN","VPR ROS4",45,0 )
  26356    ;
  26357   "RTN","VPR ROS4",46,0 )
  26358   WARD ;Proc ess patien ts for thi s ward
  26359   "RTN","VPR ROS4",47,0 )
  26360    K VPRARRA Y S VPRARR AY=""
  26361   "RTN","VPR ROS4",48,0 )
  26362    S VPRNAME ="" F  S V PRNAME=$O( ^DIC(42,"B ",VPRNAME) ) Q:VPRNAM E=""  S X= VPRNAME X  ^%ZOSF("UP PERCASE")  S UPNAME=Y  X VPRACT  I  D 
  26363   "RTN","VPR ROS4",49,0 )
  26364    . S VPRI= $O(^DIC(42 ,"B",VPRNA ME,0))
  26365   "RTN","VPR ROS4",50,0 )
  26366    . S VPRAR RAY(VPRNAM E)=VPRI
  26367   "RTN","VPR ROS4",51,0 )
  26368    . N DIVP, VPRDIV,SPE CP,SPEC,SV C,SERVICE
  26369   "RTN","VPR ROS4",52,0 )
  26370    . S (DIVP ,VPRDIV,SP ECP,SPEC,S VC,SERVICE )=""
  26371   "RTN","VPR ROS4",53,0 )
  26372    . S DIVP= $P(^DIC(42 ,VPRI,0)," ^",11) I D IVP]"" S V PRDIV=$P($ G(^DG(40.8 ,DIVP,0)), "^",1)
  26373   "RTN","VPR ROS4",54,0 )
  26374    . S SPECP =$P(^DIC(4 2,VPRI,0), "^",12) I  SPECP]"" S  SPEC=$P($ G(^DIC(42. 4,SPECP,0) ),"^",1)
  26375   "RTN","VPR ROS4",55,0 )
  26376    . S SVC=$ P(^DIC(42, VPRI,0),"^ ",3)
  26377   "RTN","VPR ROS4",56,0 )
  26378    . S SERVI CE=$S(SVC= "M":"MEDIC INE",SVC=" S":"SURGER Y",SVC="P" :"PSYCHIAT RY",SVC="N H":"NHCU", SVC="NE":" NEUROLOGY" ,SVC="I":" INTERMEDIA TE MEDICIN E",1:"")
  26379   "RTN","VPR ROS4",57,0 )
  26380    . S:'$L(S ERVICE) SE RVICE=$S(S VC="R":"RE HAB MEDICI NE",SVC="S CI":"SPINA L CORD INJ URY",SVC=" D":"DOMICI LLIARY",SV C="B":"BLI ND REHAB", 1:"NONE")
  26381   "RTN","VPR ROS4",58,0 )
  26382    . S VPRAR RAY(VPRNAM E,1)="DIVI SION"_"^"_ VPRDIV
  26383   "RTN","VPR ROS4",59,0 )
  26384    . S VPRAR RAY(VPRNAM E,2)="SPEC IALTY"_"^" _SPEC
  26385   "RTN","VPR ROS4",60,0 )
  26386    . S VPRAR RAY(VPRNAM E,3)="SERV ICE"_"^"_S ERVICE
  26387   "RTN","VPR ROS4",61,0 )
  26388    Q
  26389   "RTN","VPR ROS4",62,0 )
  26390    ;
  26391   "RTN","VPR ROS4",63,0 )
  26392   PAT ;Proce ss patient  from Pati ent file S ource
  26393   "RTN","VPR ROS4",64,0 )
  26394    K VPRARRA Y S VPRARR AY=""
  26395   "RTN","VPR ROS4",65,0 )
  26396    N DFN,SEX ,DOB,SSN,I CN,DOBOUT
  26397   "RTN","VPR ROS4",66,0 )
  26398    I VPRFILT ?1U4N D  Q
  26399   "RTN","VPR ROS4",67,0 )
  26400    . I $D(^D PT("BS5",V PRFILT)) D
  26401   "RTN","VPR ROS4",68,0 )
  26402    . . S VPR I=0 F  S V PRI=$O(^DP T("BS5",VP RFILT,VPRI )) Q:VPRI' >0  D
  26403   "RTN","VPR ROS4",69,0 )
  26404    . . . S D FN=VPRI,IC N=$$GETICN ^MPIF001(D FN)
  26405   "RTN","VPR ROS4",70,0 )
  26406    . . . K W ARN S WARN ="" D SECC HK ;ZW WAR N
  26407   "RTN","VPR ROS4",71,0 )
  26408    . . . S V PRNAME=$P( ^DPT(VPRI, 0),"^",1), VPRARRAY(V PRNAME)=VP RI
  26409   "RTN","VPR ROS4",72,0 )
  26410    . . . S S EX=$P(^DPT (VPRI,0)," ^",2),DOB= $P(^DPT(VP RI,0),"^", 3),SSN=$P( ^DPT(VPRI, 0),"^",9)
  26411   "RTN","VPR ROS4",73,0 )
  26412    . . . S D OBOUT=$$FM THL7^XLFDT (DOB)
  26413   "RTN","VPR ROS4",74,0 )
  26414    . . . S V PRARRAY(VP RNAME,1)=" ICN"_"^"_I CN
  26415   "RTN","VPR ROS4",75,0 )
  26416    . . . S V PRARRAY(VP RNAME,2)=" GENDER"_"^ "_$S(SEX=" M":"MALE", SEX="F":"F EMALE",1:" NONE")
  26417   "RTN","VPR ROS4",76,0 )
  26418    . . . S V PRARRAY(VP RNAME,3)=" DOB"_"^"_D OBOUT
  26419   "RTN","VPR ROS4",77,0 )
  26420    . . . S V PRARRAY(VP RNAME,4)=" SSN"_"^"_S SN
  26421   "RTN","VPR ROS4",78,0 )
  26422    S VPRNAME =VPRFILT
  26423   "RTN","VPR ROS4",79,0 )
  26424    I $D(^DPT ("B",VPRNA ME)) D  Q
  26425   "RTN","VPR ROS4",80,0 )
  26426    . S VPRI= 0 F  S VPR I=$O(^DPT( "B",VPRNAM E,VPRI)) Q :VPRI'>0   S VPRARRAY (VPRNAME)= VPRI D
  26427   "RTN","VPR ROS4",81,0 )
  26428    . . S DFN =VPRI,ICN= $$GETICN^M PIF001(DFN )
  26429   "RTN","VPR ROS4",82,0 )
  26430    . . K WAR N S WARN=" " D SECCHK  ;ZW WARN
  26431   "RTN","VPR ROS4",83,0 )
  26432    . . S SEX =$P(^DPT(V PRI,0),"^" ,2),DOB=$P (^DPT(VPRI ,0),"^",3) ,SSN=$P(^D PT(VPRI,0) ,"^",9)
  26433   "RTN","VPR ROS4",84,0 )
  26434    . . S DOB OUT=$$FMTH L7^XLFDT(D OB)
  26435   "RTN","VPR ROS4",85,0 )
  26436    . . S VPR ARRAY(VPRN AME,1)="IC N"_"^"_ICN
  26437   "RTN","VPR ROS4",86,0 )
  26438    . . S VPR ARRAY(VPRN AME,2)="GE NDER"_"^"_ $S(SEX="M" :"MALE",SE X="F":"FEM ALE",1:"NO NE")
  26439   "RTN","VPR ROS4",87,0 )
  26440    . . S VPR ARRAY(VPRN AME,3)="DO B"_"^"_DOB OUT
  26441   "RTN","VPR ROS4",88,0 )
  26442    . . S VPR ARRAY(VPRN AME,4)="SS N"_"^"_SSN
  26443   "RTN","VPR ROS4",89,0 )
  26444    E  F  S V PRNAME=$O( ^DPT("B",V PRNAME)) Q :VPRNAME=" "!(VPRNAME '[VPRFILT)   D
  26445   "RTN","VPR ROS4",90,0 )
  26446    . S VPRI= 0 F  S VPR I=$O(^DPT( "B",VPRNAM E,VPRI)) Q :VPRI'>0   S VPRARRAY (VPRNAME)= VPRI D
  26447   "RTN","VPR ROS4",91,0 )
  26448    . . S DFN =VPRI,ICN= $$GETICN^M PIF001(DFN )
  26449   "RTN","VPR ROS4",92,0 )
  26450    . . K WAR N S WARN=" " D SECCHK  ;ZW WARN
  26451   "RTN","VPR ROS4",93,0 )
  26452    . . S SEX =$P(^DPT(V PRI,0),"^" ,2),DOB=$P (^DPT(VPRI ,0),"^",3) ,SSN=$P(^D PT(VPRI,0) ,"^",9)
  26453   "RTN","VPR ROS4",94,0 )
  26454    . . S DOB OUT=$$FMTH L7^XLFDT(D OB)
  26455   "RTN","VPR ROS4",95,0 )
  26456    . . S VPR ARRAY(VPRN AME,1)="IC N"_"^"_ICN
  26457   "RTN","VPR ROS4",96,0 )
  26458    . . S VPR ARRAY(VPRN AME,2)="GE NDER"_"^"_ $S(SEX="M" :"MALE",SE X="F":"FEM ALE",1:"NO NE")
  26459   "RTN","VPR ROS4",97,0 )
  26460    . . S VPR ARRAY(VPRN AME,3)="DO B"_"^"_DOB OUT
  26461   "RTN","VPR ROS4",98,0 )
  26462    . . S VPR ARRAY(VPRN AME,4)="SS N"_"^"_SSN
  26463   "RTN","VPR ROS4",99,0 )
  26464    Q
  26465   "RTN","VPR ROS4",100, 0)
  26466    ;
  26467   "RTN","VPR ROS4",101, 0)
  26468   PCMM ;Proc ess patien ts from a  PCMM team
  26469   "RTN","VPR ROS4",102, 0)
  26470    K VPRARRA Y S VPRARR AY=""
  26471   "RTN","VPR ROS4",103, 0)
  26472    S VPRSTN= $P($G(^XMB (1,1,"XUS" )),"^",17)
  26473   "RTN","VPR ROS4",104, 0)
  26474    S VPRI=0  F  S VPRI= $O(^SCTM(4 04.51,"AIN ST",VPRSTN ,VPRI)) Q: VPRI'>0  S  VPRNAME=$ P($G(^SCTM (404.51,VP RI,0)),"^" ,1) S X=VP RNAME X ^% ZOSF("UPPE RCASE") S  UPNAME=Y X  VPRACT I   D
  26475   "RTN","VPR ROS4",105, 0)
  26476    . S VPRAR RAY(VPRNAM E)=VPRI
  26477   "RTN","VPR ROS4",106, 0)
  26478    . N TEAMP ,TEAMPP,SV CP,SERVICE  S (TEAMP, TEAMPP,SVC P,SERVICE) =""
  26479   "RTN","VPR ROS4",107, 0)
  26480    . S TEAMP P=$P(^SCTM (404.51,VP RI,0),"^", 3) I TEAMP P]"" S TEA MP=$P(^SD( 403.47,TEA MPP,0),"^" ,1)
  26481   "RTN","VPR ROS4",108, 0)
  26482    . S SVCP= $P(^SCTM(4 04.51,VPRI ,0),"^",6)  I SVCP]""  S SERVICE =$P(^DIC(4 9,SVCP,0), "^",1)
  26483   "RTN","VPR ROS4",109, 0)
  26484    . S VPRAR RAY(VPRNAM E,1)="TEAM  PURPOSE"_ "^"_TEAMP
  26485   "RTN","VPR ROS4",110, 0)
  26486    . S VPRAR RAY(VPRNAM E,2)="SERV ICE"_"^"_S ERVICE
  26487   "RTN","VPR ROS4",111, 0)
  26488    Q
  26489   "RTN","VPR ROS4",112, 0)
  26490    ;
  26491   "RTN","VPR ROS4",113, 0)
  26492   CPRS ;Proc ess patien ts from CP RS Lists
  26493   "RTN","VPR ROS4",114, 0)
  26494    K VPRARRA Y S VPRARR AY=""
  26495   "RTN","VPR ROS4",115, 0)
  26496    S VPRNAME ="" F  S V PRNAME=$O( ^OR(100.21 ,"B",VPRNA ME)) Q:VPR NAME=""  S  X=VPRNAME  X ^%ZOSF( "UPPERCASE ") S UPNAM E=Y X VPRA CT I  D
  26497   "RTN","VPR ROS4",116, 0)
  26498    . S VPRI= 0 F  S VPR I=$O(^OR(1 00.21,"B", VPRNAME,VP RI)) Q:VPR I'>0  D
  26499   "RTN","VPR ROS4",117, 0)
  26500    . . S VPR ARRAY(VPRN AME)=VPRI
  26501   "RTN","VPR ROS4",118, 0)
  26502    . . N TYP E,CREATP,C REATOR
  26503   "RTN","VPR ROS4",119, 0)
  26504    . . S TYP E=$P(^OR(1 00.21,VPRI ,0),"^",2)
  26505   "RTN","VPR ROS4",120, 0)
  26506    . . S TYP ENM=$S(TYP E="P":"PER SONAL PATI ENT",TYPE= "TA":"TEAM  PATIENT A UTOLINKED" ,TYPE="TM" :"TEAM PAT IENT MANUA L",TYPE="M RAL":"MANU AL REMOVAL  AUTOLINK  ADDITION", 1:"NONE")
  26507   "RTN","VPR ROS4",121, 0)
  26508    . . S CRE ATP=$P(^OR (100.21,VP RI,0),"^", 5),CREATOR =""
  26509   "RTN","VPR ROS4",122, 0)
  26510    . . I CRE ATP]"" S C REATOR=$P( $G(^VA(200 ,CREATP,0) ),"^",1)
  26511   "RTN","VPR ROS4",123, 0)
  26512    . . S VPR ARRAY(VPRN AME,1)="TY PE"_"^"_TY PENM
  26513   "RTN","VPR ROS4",124, 0)
  26514    . . S VPR ARRAY(VPRN AME,2)="CR EATOR"_"^" _CREATOR
  26515   "RTN","VPR ROS4",125, 0)
  26516    Q
  26517   "RTN","VPR ROS4",126, 0)
  26518    ;
  26519   "RTN","VPR ROS4",127, 0)
  26520   ROST ;Proc ess patien ts from se lected ros ter
  26521   "RTN","VPR ROS4",128, 0)
  26522    K VPRARRA Y S VPRARR AY=""
  26523   "RTN","VPR ROS4",129, 0)
  26524    S VPRNAME ="" F  S V PRNAME=$O( ^VPROSTER( "B",VPRNAM E)) Q:VPRN AME=""  S  X=VPRNAME  X ^%ZOSF(" UPPERCASE" ) S UPNAME =Y X VPRAC T I  D
  26525   "RTN","VPR ROS4",130, 0)
  26526    . S VPRI= $O(^VPROST ER("B",VPR NAME,0)) S  VPRARRAY( VPRNAME)=V PRI
  26527   "RTN","VPR ROS4",131, 0)
  26528    . N DISP, OWNERP,OWN ER
  26529   "RTN","VPR ROS4",132, 0)
  26530    . S DISP= $P(^VPROST ER(VPRI,0) ,"^",2)
  26531   "RTN","VPR ROS4",133, 0)
  26532    . S OWNER P=$P(^VPRO STER(VPRI, 0),"^",4), OWNER=""
  26533   "RTN","VPR ROS4",134, 0)
  26534    . I OWNER P]"" S OWN ER=$P($G(^ VA(200,OWN ERP,0)),"^ ",1)
  26535   "RTN","VPR ROS4",135, 0)
  26536    . S VPRAR RAY(VPRNAM E,1)="DISP LAY NAME"_ "^"_DISP
  26537   "RTN","VPR ROS4",136, 0)
  26538    . S VPRAR RAY(VPRNAM E,2)="OWNE R"_"^"_OWN ER
  26539   "RTN","VPR ROS4",137, 0)
  26540    Q
  26541   "RTN","VPR ROS4",138, 0)
  26542    ;
  26543   "RTN","VPR ROS4",139, 0)
  26544   SPEC ;Proc ess patien ts with se lected Tre ating Spec ialty
  26545   "RTN","VPR ROS4",140, 0)
  26546    K VPRARRA Y S VPRARR AY=""
  26547   "RTN","VPR ROS4",141, 0)
  26548    S VPRNAME ="" F  S V PRNAME=$O( ^DIC(45.7, "B",VPRNAM E)) Q:VPRN AME=""  S  X=VPRNAME  X ^%ZOSF(" UPPERCASE" ) S UPNAME =Y X VPRAC T I  D
  26549   "RTN","VPR ROS4",142, 0)
  26550    . S VPRI= $O(^DIC(45 .7,"B",VPR NAME,0)),V DATE=$O(^D IC(45.7,VP RI,"E","AD ATE","")), ACT=$O(^DI C(45.7,VPR I,"E","ADA TE",VDATE, 0)),ACTIVE =$P(^DIC(4 5.7,VPRI," E",ACT,0), "^",2)
  26551   "RTN","VPR ROS4",143, 0)
  26552    . I ACTIV E D
  26553   "RTN","VPR ROS4",144, 0)
  26554    . . S VPR ARRAY(VPRN AME)=VPRI
  26555   "RTN","VPR ROS4",145, 0)
  26556    . . N SVC ,SERVICE
  26557   "RTN","VPR ROS4",146, 0)
  26558    . . S SVC =$P(^DIC(4 5.7,VPRI,0 ),"^",3)
  26559   "RTN","VPR ROS4",147, 0)
  26560    . . S SER VICE=$S(SV C="M":"MED ICINE",SVC ="S":"SURG ERY",SVC=" P":"PSYCHI ATRY",SVC= "NH":"NHCU ",SVC="NE" :"NEUROLOG Y",SVC="I" :"INTERMED IATE MEDIC INE",1:"")
  26561   "RTN","VPR ROS4",148, 0)
  26562    . . S:'$L (SERVICE)  SERVICE=$S (SVC="R":" REHAB MEDI CINE",SVC= "SCI":"SPI NAL CORD I NJURY",SVC ="D":"DOMI CILLIARY", SVC="B":"B LIND REHAB ",SVC="RE" :"RESPITE  CARE",1:"N ONE")
  26563   "RTN","VPR ROS4",149, 0)
  26564    . . S VPR ARRAY(VPRN AME,1)="SE RVICE"_"^" _SERVICE
  26565   "RTN","VPR ROS4",150, 0)
  26566    Q
  26567   "RTN","VPR ROS4",151, 0)
  26568    ;
  26569   "RTN","VPR ROS4",152, 0)
  26570   PROV ;Proc ess patien ts for sel ected prov ider
  26571   "RTN","VPR ROS4",153, 0)
  26572    K VPRARRA Y S VPRARR AY=""
  26573   "RTN","VPR ROS4",154, 0)
  26574    N TITLEP, VTITLE,SEX
  26575   "RTN","VPR ROS4",155, 0)
  26576    S VTITLE= ""
  26577   "RTN","VPR ROS4",156, 0)
  26578    I VPRFILT '="" D
  26579   "RTN","VPR ROS4",157, 0)
  26580    . S VPRNA ME=VPRFILT
  26581   "RTN","VPR ROS4",158, 0)
  26582    . F  S VP RNAME=$O(^ VA(200,"B" ,VPRNAME))  Q:VPRNAME =""!(VPRNA ME'[VPRFIL T)  D
  26583   "RTN","VPR ROS4",159, 0)
  26584    . . S VPR I=0 F  S V PRI=$O(^VA (200,"B",V PRNAME,VPR I)) Q:VPRI '>0  D
  26585   "RTN","VPR ROS4",160, 0)
  26586    . . . S T ITLEP=$P(^ VA(200,VPR I,0),"^",9 ) I TITLEP ]"" S VTIT LE=$P($G(^ DIC(3.1,TI TLEP,0))," ^",1)
  26587   "RTN","VPR ROS4",161, 0)
  26588    . . . S S EX=$P(^VA( 200,VPRI,1 ),"^",2)
  26589   "RTN","VPR ROS4",162, 0)
  26590    . . . S V PRARRAY(VP RNAME)=VPR I
  26591   "RTN","VPR ROS4",163, 0)
  26592    . . . S V PRARRAY(VP RNAME,1)=" SEX"_"^"_S EX
  26593   "RTN","VPR ROS4",164, 0)
  26594    . . . S V PRARRAY(VP RNAME,2)=" TITLE"_"^" _VTITLE
  26595   "RTN","VPR ROS4",165, 0)
  26596    I VPRFILT ="" D
  26597   "RTN","VPR ROS4",166, 0)
  26598    . S VPRNA ME="" F  S  VPRNAME=$ O(^VA(200, "B",VPRNAM E)) Q:VPRN AME=""  D
  26599   "RTN","VPR ROS4",167, 0)
  26600    . . S VPR I=0 F  S V PRI=$O(^VA (200,"B",V PRNAME,VPR I)) Q:VPRI '>0  D
  26601   "RTN","VPR ROS4",168, 0)
  26602    . . . S T ITLEP=$P(^ VA(200,VPR I,0),"^",9 ) I TITLEP ]"" S VTIT LE=$P($G(^ DIC(3.1,TI TLEP,0))," ^",1)
  26603   "RTN","VPR ROS4",169, 0)
  26604    . . . S S EX=$P(^VA( 200,VPRI,1 ),"^",2)
  26605   "RTN","VPR ROS4",170, 0)
  26606    . . . S V PRARRAY(VP RNAME)=VPR I
  26607   "RTN","VPR ROS4",171, 0)
  26608    . . . S V PRARRAY(VP RNAME,1)=" SEX"_"^"_S EX
  26609   "RTN","VPR ROS4",172, 0)
  26610    . . . S V PRARRAY(VP RNAME,2)=" TITLE"_"^" _VTITLE
  26611   "RTN","VPR ROS4",173, 0)
  26612    Q
  26613   "RTN","VPR ROS4",174, 0)
  26614    ;
  26615   "RTN","VPR ROS4",175, 0)
  26616   PXRM ;Proc ess patien ts for sel ected pane l
  26617   "RTN","VPR ROS4",176, 0)
  26618    K VPRARRA Y S VPRARR AY=""
  26619   "RTN","VPR ROS4",177, 0)
  26620    S VPRNAME ="" F  S V PRNAME=$O( ^PXRM(810. 4,"B",VPRN AME)) Q:VP RNAME=""   S X=VPRNAM E X ^%ZOSF ("UPPERCAS E") S UPNA ME=Y X VPR ACT I  D
  26621   "RTN","VPR ROS4",178, 0)
  26622    . S VPRI= 0 F  S VPR I=$O(^PXRM (810.4,"B" ,VPRNAME,V PRI)) Q:VP RI'>0  I $ P($G(^PXRM (810.4,VPR I,0)),"^", 3)=3 D
  26623   "RTN","VPR ROS4",179, 0)
  26624    . . S VPR ARRAY(VPRN AME)=VPRI
  26625   "RTN","VPR ROS4",180, 0)
  26626    . . N LIS TP,LISTN,C LASS,CLASS NM
  26627   "RTN","VPR ROS4",181, 0)
  26628    . . S (LI STP,LISTN, CLASS,CLAS SNM)="" ;a dded 3/15/ 11 grr
  26629   "RTN","VPR ROS4",182, 0)
  26630    . . S LIS TP=$P(^PXR M(810.4,VP RI,0),"^", 7) I LISTP ]"" S LIST N=$P(^PXRM D(811.5,LI STP,0),"^" ,1)
  26631   "RTN","VPR ROS4",183, 0)
  26632    . . S CLA SS=$P(^PXR M(810.4,VP RI,100),"^ ",1),CLASS NM=$S(CLAS S="N":"Nat ional",CLA SS="V":"VI SN",CLASS= "L":"Local ",1:"NONE" )
  26633   "RTN","VPR ROS4",184, 0)
  26634    . . S VPR ARRAY(VPRN AME,1)="TE RM"_"^"_LI STN
  26635   "RTN","VPR ROS4",185, 0)
  26636    . . S VPR ARRAY(VPRN AME,2)="CL ASS"_"^"_C LASSNM
  26637   "RTN","VPR ROS4",186, 0)
  26638    Q
  26639   "RTN","VPR ROS4",187, 0)
  26640    ;
  26641   "RTN","VPR ROS4",188, 0)
  26642   SEND ;send  pending r osters.  C alled thro ugh RPC
  26643   "RTN","VPR ROS4",189, 0)
  26644    S VPRRCNT =0,VPRI=0
  26645   "RTN","VPR ROS4",190, 0)
  26646    S VPRVER= "<results  version='" _$P($T(VPR ROS4+1),"; ",3)_"'>"
  26647   "RTN","VPR ROS4",191, 0)
  26648    D ADD(VPR VER)
  26649   "RTN","VPR ROS4",192, 0)
  26650    S VPRTEXT ="<source  name='"_VP RSRC_"' >"  D ADD(VPR TEXT)
  26651   "RTN","VPR ROS4",193, 0)
  26652    D ADD("<e ntries>")
  26653   "RTN","VPR ROS4",194, 0)
  26654    K VPRII S  VPRII=""  F  S VPRII =$O(VPRARR AY(VPRII))  Q:VPRII=" "  D
  26655   "RTN","VPR ROS4",195, 0)
  26656    . S VPRDA TA=$$ESC^V PRD(VPRII)
  26657   "RTN","VPR ROS4",196, 0)
  26658    . S VPRTE XT="<entry  NAME='"_V PRDATA_"'  id='"_VPRA RRAY(VPRII )_"' />" D  ADD(VPRTE XT)
  26659   "RTN","VPR ROS4",197, 0)
  26660    . D ADD(" <identifie rs>")
  26661   "RTN","VPR ROS4",198, 0)
  26662    . N I S I =0 F  S I= $O(VPRARRA Y(VPRII,I) ) Q:I'>0   D
  26663   "RTN","VPR ROS4",199, 0)
  26664    . . S IDN AME=$P(VPR ARRAY(VPRI I,I),"^",1 ),IDVALUE= $P(VPRARRA Y(VPRII,I) ,"^",2),ID VALUE=$$ES C^VPRD(IDV ALUE)
  26665   "RTN","VPR ROS4",200, 0)
  26666    . . S VPR TEXT="<ide nt name='" _IDNAME_"'  value='"_ IDVALUE_"'  />" D ADD (VPRTEXT)
  26667   "RTN","VPR ROS4",201, 0)
  26668    . D ADD(" </identifi ers>")
  26669   "RTN","VPR ROS4",202, 0)
  26670    D ADD("</ entries>")
  26671   "RTN","VPR ROS4",203, 0)
  26672    D ADD("</ source>")
  26673   "RTN","VPR ROS4",204, 0)
  26674    S VPRTEXT ="</result s>" D ADD( VPRTEXT)
  26675   "RTN","VPR ROS4",205, 0)
  26676    Q
  26677   "RTN","VPR ROS4",206, 0)
  26678    ;
  26679   "RTN","VPR ROS4",207, 0)
  26680   ADD(X) ; - - Add a li ne @VPR@(n )=X
  26681   "RTN","VPR ROS4",208, 0)
  26682    I X'["<"  S X=$$ESC^ VPRD(X)
  26683   "RTN","VPR ROS4",209, 0)
  26684    S VPRI=$G (VPRI)+1
  26685   "RTN","VPR ROS4",210, 0)
  26686    S @VPR@(V PRI)=X
  26687   "RTN","VPR ROS4",211, 0)
  26688    Q
  26689   "RTN","VPR ROS4",212, 0)
  26690    ;
  26691   "RTN","VPR ROS4",213, 0)
  26692   SECCHK ; c heck for s ensitive r ecord
  26693   "RTN","VPR ROS4",214, 0)
  26694    N VPRY,I, X
  26695   "RTN","VPR ROS4",215, 0)
  26696    K WARN
  26697   "RTN","VPR ROS4",216, 0)
  26698    D PTSEC^D GSEC4(.VPR Y,DFN,1)   ;IA #3027
  26699   "RTN","VPR ROS4",217, 0)
  26700    S CHK("df n")=DFN
  26701   "RTN","VPR ROS4",218, 0)
  26702    S CHK("se nsitive")= (VPRY(1)>0 )
  26703   "RTN","VPR ROS4",219, 0)
  26704    S CHK("ma yAccess")= (VPRY(1)<3 )
  26705   "RTN","VPR ROS4",220, 0)
  26706    S CHK("lo gAccess")= (VPRY(1)>1 )
  26707   "RTN","VPR ROS4",221, 0)
  26708    M WARN=VP RY K WARN( 1)
  26709   "RTN","VPR ROS4",222, 0)
  26710    ;
  26711   "RTN","VPR ROS5")
  26712   0^16^B9679 013
  26713   "RTN","VPR ROS5",1,0)
  26714   VPRROS5 ;S LC/GRR --  Clinical R eminders L ist Proces sing
  26715   "RTN","VPR ROS5",2,0)
  26716    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  26717   "RTN","VPR ROS5",3,0)
  26718    ;
  26719   "RTN","VPR ROS5",4,0)
  26720    ; Externa l Referenc es           DBIA#
  26721   "RTN","VPR ROS5",5,0)
  26722    ; ------- ---------- --           -----
  26723   "RTN","VPR ROS5",6,0)
  26724    ;
  26725   "RTN","VPR ROS5",7,0)
  26726    ; ------- ----- Get  Panel(s) f rom VistA  ---------- --
  26727   "RTN","VPR ROS5",8,0)
  26728    ;
  26729   "RTN","VPR ROS5",9,0)
  26730   EN(VPR) ;  -- find Pa nels to up date
  26731   "RTN","VPR ROS5",10,0 )
  26732    K ^TMP($J ,"VPRPANEL ")
  26733   "RTN","VPR ROS5",11,0 )
  26734    N VPRPAN, VPRPAT,VPR I,MSG,PATC REAT,PLIST PUG,VPRC,V PRT
  26735   "RTN","VPR ROS5",12,0 )
  26736    N VPRSYS  S VPRSYS=$ $GET^XPAR( "SYS","VPR  SYSTEM NA ME")
  26737   "RTN","VPR ROS5",13,0 )
  26738    S VPR=$NA (^TMP($J," VPR")),VPR C=0,VPRT=0
  26739   "RTN","VPR ROS5",14,0 )
  26740    F  S VPRC =$O(^VPRPA NEL(VPRC))  Q:VPRC'>0   D
  26741   "RTN","VPR ROS5",15,0 )
  26742    . S VPRT= VPRT+1
  26743   "RTN","VPR ROS5",16,0 )
  26744    . S VPRPA N(VPRC)=^V PRPANEL(VP RC,0) D
  26745   "RTN","VPR ROS5",17,0 )
  26746    . N LIEN, PLNAME S L IEN=$P(VPR PAN(VPRC), "^"),PLNAM E=$P(VPRPA N(VPRC),U, 3)
  26747   "RTN","VPR ROS5",18,0 )
  26748    . ;agp ne ed to dete rmine what  secure an d over sho uld be set  to
  26749   "RTN","VPR ROS5",19,0 )
  26750    . S SECUR E=0,OVER=1
  26751   "RTN","VPR ROS5",20,0 )
  26752    . D RUNLI ST(.VPRPAN ,LIEN,PLNA ME,SECURE, OVER)
  26753   "RTN","VPR ROS5",21,0 )
  26754   CREATE ; - - create p anel(s) in  XML
  26755   "RTN","VPR ROS5",22,0 )
  26756    N VPRVER  S VPRVER=" <results v ersion='"_ $P($T(VPRP ANEL+1),"; ",3)_"'>"
  26757   "RTN","VPR ROS5",23,0 )
  26758    N VPRTTXT  S VPRTTXT ="<panels  total='"_V PRT_"'>"
  26759   "RTN","VPR ROS5",24,0 )
  26760    D ADD(VPR VER),ADD(V PRTTXT)
  26761   "RTN","VPR ROS5",25,0 )
  26762    D PANEL
  26763   "RTN","VPR ROS5",26,0 )
  26764    S TEXT="< /results>"  D ADD(TEX T)
  26765   "RTN","VPR ROS5",27,0 )
  26766    Q
  26767   "RTN","VPR ROS5",28,0 )
  26768    ;
  26769   "RTN","VPR ROS5",29,0 )
  26770   PANEL ;--  create pan el XML
  26771   "RTN","VPR ROS5",30,0 )
  26772    S VPRC=0  F  S VPRC= $O(VPRPAN( VPRC)) Q:V PRC'>0  D
  26773   "RTN","VPR ROS5",31,0 )
  26774    .D ADD("< panel>")
  26775   "RTN","VPR ROS5",32,0 )
  26776    .N TEXT S  TEXT="<pa nel name=' "_$P(VPRPA N(VPRC),"^ ",2)_"' /> " D ADD(TE XT)
  26777   "RTN","VPR ROS5",33,0 )
  26778    .S TEXT=" <panelStri ng code='" _$P(VPRPAN (VPRC),"^" )_"' />" D  ADD(TEXT)
  26779   "RTN","VPR ROS5",34,0 )
  26780    .D PATS
  26781   "RTN","VPR ROS5",35,0 )
  26782    .S TEXT=" </panel>"  D ADD(TEXT )
  26783   "RTN","VPR ROS5",36,0 )
  26784    S TEXT="< /panels>"  D ADD(TEXT )
  26785   "RTN","VPR ROS5",37,0 )
  26786    Q
  26787   "RTN","VPR ROS5",38,0 )
  26788    ;
  26789   "RTN","VPR ROS5",39,0 )
  26790   CREATEPL(P LNAME,SECU RE,OVER) ;
  26791   "RTN","VPR ROS5",40,0 )
  26792    N FDA,IEN S,NAME,NUM ,RESULT,UN IQUE
  26793   "RTN","VPR ROS5",41,0 )
  26794    S (NUM,RE SULT,UNIQU E)=0
  26795   "RTN","VPR ROS5",42,0 )
  26796    ;if overw rite check  to see if  the list  exist
  26797   "RTN","VPR ROS5",43,0 )
  26798    I OVER=1  S RESULT=$ O(^PXRMXP( 810.5,"B", PLNAME,"") )
  26799   "RTN","VPR ROS5",44,0 )
  26800    I RESULT> 0 Q RESULT
  26801   "RTN","VPR ROS5",45,0 )
  26802    S NAME=PL NAME
  26803   "RTN","VPR ROS5",46,0 )
  26804    ;if not o verwrite f ind unique  name
  26805   "RTN","VPR ROS5",47,0 )
  26806    I OVER=0  D
  26807   "RTN","VPR ROS5",48,0 )
  26808    .I $D(^PX RMXP(810.5 ,"B",NAME) )=0 Q
  26809   "RTN","VPR ROS5",49,0 )
  26810    .F  Q:UNI QUE=1  D
  26811   "RTN","VPR ROS5",50,0 )
  26812    ..S NUM=N UM+1
  26813   "RTN","VPR ROS5",51,0 )
  26814    ..S NAME= PLNAME_" ( "_NUM_")"
  26815   "RTN","VPR ROS5",52,0 )
  26816    ..I $D(^P XRMXP(810. 5,"B",NAME ))=0 S UNI QUE=1
  26817   "RTN","VPR ROS5",53,0 )
  26818    ;create s tub in 810 .5
  26819   "RTN","VPR ROS5",54,0 )
  26820    S IENS="+ 1,"
  26821   "RTN","VPR ROS5",55,0 )
  26822    S FDA(810 .5,IENS,.0 1)=NAME
  26823   "RTN","VPR ROS5",56,0 )
  26824    S FDA(810 .5,IENS,10 0)="L"
  26825   "RTN","VPR ROS5",57,0 )
  26826    S FDA(810 .5,IENS,.0 7)=DUZ
  26827   "RTN","VPR ROS5",58,0 )
  26828    S FDA(810 .5,IENS,.0 8)=$S(SECU RE=0:"PUB" ,1:"PVT")
  26829   "RTN","VPR ROS5",59,0 )
  26830    D UPDATE^ DIE("","FD A","","MSG ")
  26831   "RTN","VPR ROS5",60,0 )
  26832    ;if error  display m essage and  quit
  26833   "RTN","VPR ROS5",61,0 )
  26834    I $D(MSG)  D AWRITE^ PXRMUTIL(" MSG") Q 0
  26835   "RTN","VPR ROS5",62,0 )
  26836    S RESULT= $O(^PXRMXP (810.5,"B" ,NAME,""))
  26837   "RTN","VPR ROS5",63,0 )
  26838    Q RESULT
  26839   "RTN","VPR ROS5",64,0 )
  26840    ;
  26841   "RTN","VPR ROS5",65,0 )
  26842   RUNLIST(VP RPAN,LIEN, PLNAME,SEC URE,OVER)  ;
  26843   "RTN","VPR ROS5",66,0 )
  26844    N PLIEN
  26845   "RTN","VPR ROS5",67,0 )
  26846    S PLIEN=$ $CREATEPL( PLNAME,SEC URE,OVER)
  26847   "RTN","VPR ROS5",68,0 )
  26848    S PATCREA T=$S(SECUR E=1:"Y",1: 0),PLISTPU G=1
  26849   "RTN","VPR ROS5",69,0 )
  26850    I PLIEN=0  Q
  26851   "RTN","VPR ROS5",70,0 )
  26852    D RUN^PXR MLCR(LIEN, PLIEN,"PXR MRULE",DT, DT,0,0)
  26853   "RTN","VPR ROS5",71,0 )
  26854    N VPRPAT  S VPRPAT=0
  26855   "RTN","VPR ROS5",72,0 )
  26856    F  S VPRP AT=$O(^PXR MXP(810.5, PLIEN,30,V PRPAT)) Q: VPRPAT'>0   S VPRPAN( VPRC,VPRPA T)=$P($G(^ PXRMXP(810 .5,PLIEN,3 0,VPRPAT,0 )),"^",1)
  26857   "RTN","VPR ROS5",73,0 )
  26858    Q
  26859   "RTN","VPR ROS5",74,0 )
  26860    ;
  26861   "RTN","VPR ROS5",75,0 )
  26862   PATS ; --  create pat ient XML
  26863   "RTN","VPR ROS5",76,0 )
  26864    S TEXT="< patients>"  D ADD(TEX T)
  26865   "RTN","VPR ROS5",77,0 )
  26866    S VPRPAT= 0 F  S VPR PAT=$O(VPR PAN(VPRC,V PRPAT)) D   Q:VPRPAT' >0
  26867   "RTN","VPR ROS5",78,0 )
  26868    .I VPRPAT '>0 S TEXT ="</patien ts>" D ADD (TEXT) Q
  26869   "RTN","VPR ROS5",79,0 )
  26870    .S TEXT=" <patient c ode='"_VPR PAN(VPRC,V PRPAT)_"'  />" D ADD( TEXT)
  26871   "RTN","VPR ROS5",80,0 )
  26872    ;
  26873   "RTN","VPR ROS5",81,0 )
  26874    ;
  26875   "RTN","VPR ROS5",82,0 )
  26876   ADD(X) ; - - Add a li ne @VPR@(n )=X
  26877   "RTN","VPR ROS5",83,0 )
  26878    S VPRI=$G (VPRI)+1
  26879   "RTN","VPR ROS5",84,0 )
  26880    S @VPR@(V PRI)=X
  26881   "RTN","VPR ROS5",85,0 )
  26882    Q
  26883   "RTN","VPR ROS5",86,0 )
  26884    ;
  26885   "RTN","VPR ROS5",87,0 )
  26886   NITELY ; - - Nightly  run to upd ate all Pa nels
  26887   "RTN","VPR ROS5",88,0 )
  26888    ;
  26889   "RTN","VPR ROS6")
  26890   0^61^B2649 2527
  26891   "RTN","VPR ROS6",1,0)
  26892   VPRROS6 ;S LC/GRR --  Generate R oster Pati ents
  26893   "RTN","VPR ROS6",2,0)
  26894    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  26895   "RTN","VPR ROS6",3,0)
  26896    ;; Compil e Roster
  26897   "RTN","VPR ROS6",4,0)
  26898   GET(VPRIEN ) ;
  26899   "RTN","VPR ROS6",5,0)
  26900    ;; Input  - VPRIEN i s internal  entry num ber of ros ter
  26901   "RTN","VPR ROS6",6,0)
  26902    ;;          VPROWNER  - If this  parameter  exists, o nly roster s for this  owner wil l be compi led and pa ssed
  26903   "RTN","VPR ROS6",7,0)
  26904    ;; Output  - AFTER a rray conta ins curren t patients
  26905   "RTN","VPR ROS6",8,0)
  26906    ;
  26907   "RTN","VPR ROS6",9,0)
  26908    K VPRLIST ,VPRLIST2
  26909   "RTN","VPR ROS6",10,0 )
  26910    N VPRI,VP RFILT,VPRT YPE,VPERR, VPRRNAME,V PRNY,VPROP ,VPRTAG,VP RLAB,VPRNL IST,BEG,DO B,END,GEND ER,ICN,NAM E,VPRACT,V PRC
  26911   "RTN","VPR ROS6",11,0 )
  26912    N VPRCIEN ,VPRDNAME, VPRDOB,VPR III,VPRINM ,VPRLIEN,V PRNAME,VPR OIEN,VPRON AME,VPROWN ID,VPROWNN M,VPRPAT,V PRPIEN,VPR NME,VPRCNT
  26913   "RTN","VPR ROS6",12,0 )
  26914    N VPRSRCD N,VPRCID,V PRTEXT,VPR TIEN,VPRTL ST,VPRVER, VPRWIEN,VP RWNAME,VPR PNME,VPRRC NT,VPRSRCI D,X,Y,SSN, VPRZ,VPRIZ ,VPRX
  26915   "RTN","VPR ROS6",13,0 )
  26916    N VPRSYS  S VPRSYS=$ $GET^XPAR( "SYS","VPR  SYSTEM NA ME")
  26917   "RTN","VPR ROS6",14,0 )
  26918    S VPRIZ=0
  26919   "RTN","VPR ROS6",15,0 )
  26920    I $G(VPRI EN)="" S V PRIEN=0
  26921   "RTN","VPR ROS6",16,0 )
  26922    S (VPRLIS T,VPRFILT, VPRTYPE,VP ROP,VPRLIS T2,VPERR)= ""
  26923   "RTN","VPR ROS6",17,0 )
  26924    I +$G(VPR IEN)'>0 S  VPERR="0^I nvalid Ros ter IEN" Q
  26925   "RTN","VPR ROS6",18,0 )
  26926    S VPRRNAM E=$P($G(^V PROSTER(VP RIEN,0))," ^",1) I VP RRNAME=""  S VPERR="0 ^Deleted R oster IEN"  Q
  26927   "RTN","VPR ROS6",19,0 )
  26928    F  S VPRI Z=$O(^VPRO STER(VPRIE N,1,VPRIZ) ) Q:VPRIZ' >0  D
  26929   "RTN","VPR ROS6",20,0 )
  26930    . S VPRX= $G(^VPROST ER(VPRIEN, 1,VPRIZ,0) )
  26931   "RTN","VPR ROS6",21,0 )
  26932    . S VPROP =$P(VPRX," ^",3)
  26933   "RTN","VPR ROS6",22,0 )
  26934    . S VPRFI LT=$P(VPRX ,"^",4)
  26935   "RTN","VPR ROS6",23,0 )
  26936    . S VPRTA G=$P($P(VP RX,"^",2), ";",2)
  26937   "RTN","VPR ROS6",24,0 )
  26938    . S VPRLA B=""
  26939   "RTN","VPR ROS6",25,0 )
  26940    . I VPRTA G["SC(" S  VPRLAB="CL IN"
  26941   "RTN","VPR ROS6",26,0 )
  26942    . I VPRTA G["DIC(42"  S VPRLAB= "WARD"
  26943   "RTN","VPR ROS6",27,0 )
  26944    . I VPRTA G["DPT" S  VPRLAB="PA T"
  26945   "RTN","VPR ROS6",28,0 )
  26946    . I VPRTA G["SCTM" S  VPRLAB="P CMM"
  26947   "RTN","VPR ROS6",29,0 )
  26948    . I VPRTA G["OR(100. 21" S VPRL AB="CPRS"
  26949   "RTN","VPR ROS6",30,0 )
  26950    . I VPRTA G["VPROSTE R" S VPRLA B="ROST"
  26951   "RTN","VPR ROS6",31,0 )
  26952    . I VPRTA G["DIC(45. 7" S VPRLA B="SPEC"
  26953   "RTN","VPR ROS6",32,0 )
  26954    . I VPRTA G["VA(200"  S VPRLAB= "PROV"
  26955   "RTN","VPR ROS6",33,0 )
  26956    . I VPRTA G["PXRM(81 0.4" S VPR LAB="PXRM"
  26957   "RTN","VPR ROS6",34,0 )
  26958    . I VPRLA B="" S VPE RR="1^INVA LID FILE T YPE" Q
  26959   "RTN","VPR ROS6",35,0 )
  26960    . D @VPRL AB
  26961   "RTN","VPR ROS6",36,0 )
  26962    . S VPRLA B=$S(VPROP =0:"UNION" ,VPROP=1:" INTER",1:" DIFF")
  26963   "RTN","VPR ROS6",37,0 )
  26964    . S VPRNL IST=""
  26965   "RTN","VPR ROS6",38,0 )
  26966    . D @VPRL AB
  26967   "RTN","VPR ROS6",39,0 )
  26968    M VPRLIST 2=VPRLIST
  26969   "RTN","VPR ROS6",40,0 )
  26970    D GENPAT( VPRIEN)
  26971   "RTN","VPR ROS6",41,0 )
  26972    Q
  26973   "RTN","VPR ROS6",42,0 )
  26974    ;
  26975   "RTN","VPR ROS6",43,0 )
  26976   CLIN ;Proc ess patien ts for thi s clinic.   Select al l if filte r is null
  26977   "RTN","VPR ROS6",44,0 )
  26978    K VPRLIST 2 S VPRLIS T2=""
  26979   "RTN","VPR ROS6",45,0 )
  26980    I '$D(DT)  S DT=$$DT ^XLFDT()
  26981   "RTN","VPR ROS6",46,0 )
  26982    S BEG=DT, END=$S(VPR FILT="T":D T+.24,1:99 99999+.24) ,VPRIII=BE G
  26983   "RTN","VPR ROS6",47,0 )
  26984    S VPRCIEN =+$P(VPRX, "^",2) F   S VPRIII=$ O(^SC(VPRC IEN,"S",VP RIII)) Q:V PRIII'>0!( VPRIII>END )  D
  26985   "RTN","VPR ROS6",48,0 )
  26986    . S VPRII =0 F  S VP RII=$O(^SC (VPRCIEN," S",VPRIII, 1,VPRII))  Q:VPRII'>0   S DFN=$P ($G(^SC(VP RCIEN,"S", VPRIII,1,V PRII,0))," ^",1) I DF N>0 D
  26987   "RTN","VPR ROS6",49,0 )
  26988    . .S VPRL IST2(DFN)= VPRIZ
  26989   "RTN","VPR ROS6",50,0 )
  26990    Q
  26991   "RTN","VPR ROS6",51,0 )
  26992    ;
  26993   "RTN","VPR ROS6",52,0 )
  26994   WARD ;Proc ess patien ts for thi s ward
  26995   "RTN","VPR ROS6",53,0 )
  26996    K VPRLIST 2 S VPRLIS T2=""
  26997   "RTN","VPR ROS6",54,0 )
  26998    S VPRWIEN =+$P(VPRX, "^",2),VPR WNAME=$P($ G(^DIC(42, VPRWIEN,0) ),"^",1)
  26999   "RTN","VPR ROS6",55,0 )
  27000    S VPRIII= 0 F  S VPR III=$O(^DG PM("CN",VP RWNAME,VPR III)) Q:VP RIII'>0  D
  27001   "RTN","VPR ROS6",56,0 )
  27002    . S DFN=$ P($G(^DGPM (VPRIII,0) ),"^",3),V PRLIST2(DF N)=VPRIZ
  27003   "RTN","VPR ROS6",57,0 )
  27004    Q
  27005   "RTN","VPR ROS6",58,0 )
  27006    ;
  27007   "RTN","VPR ROS6",59,0 )
  27008   PAT ;Proce ss patient  from Pati ent file S ource
  27009   "RTN","VPR ROS6",60,0 )
  27010    K VPRLIST 2 S VPRLIS T2=""
  27011   "RTN","VPR ROS6",61,0 )
  27012    S DFN=+$P (VPRX,"^", 2),VPRLIST 2(DFN)=VPR IZ
  27013   "RTN","VPR ROS6",62,0 )
  27014    Q
  27015   "RTN","VPR ROS6",63,0 )
  27016    ;
  27017   "RTN","VPR ROS6",64,0 )
  27018   PCMM ;Proc ess patien ts from a  PCMM team
  27019   "RTN","VPR ROS6",65,0 )
  27020    K VPRLIST 2 S VPRLIS T2=""
  27021   "RTN","VPR ROS6",66,0 )
  27022    S VPRTIEN =+$P(VPRX, "^",2),VPE RR="",VPRT LST=""
  27023   "RTN","VPR ROS6",67,0 )
  27024    D PTTM^SC APMC(VPRTI EN,,"VPRTL ST",VPERR)
  27025   "RTN","VPR ROS6",68,0 )
  27026    S VPRIII= "" F  S VP RIII=$O(VP RTLST(VPRI II)) Q:VPR III'>0  S  DFN=$P(VPR TLST(VPRII I),"^",1)  S VPRTST2( DFN)=VPRIZ
  27027   "RTN","VPR ROS6",69,0 )
  27028    Q
  27029   "RTN","VPR ROS6",70,0 )
  27030    ;
  27031   "RTN","VPR ROS6",71,0 )
  27032   CPRS ;Proc ess patien ts from CP RS Lists
  27033   "RTN","VPR ROS6",72,0 )
  27034    K VPRLIST 2 S VPRLIS T2=""
  27035   "RTN","VPR ROS6",73,0 )
  27036    S VPROIEN =+$P(VPRX, "^",2),VPE RR=""
  27037   "RTN","VPR ROS6",74,0 )
  27038    S VPRIII= 0 F  S VPR III=$O(^OR (100.21,VP ROIEN,10,V PRIII)) Q: VPRIII'>0   S DFN=$P( ^OR(100.21 ,VPROIEN,1 0,VPRIII,0 ),";",1) S  VPRLIST2( DFN)=VPRIZ
  27039   "RTN","VPR ROS6",75,0 )
  27040    Q
  27041   "RTN","VPR ROS6",76,0 )
  27042    ;
  27043   "RTN","VPR ROS6",77,0 )
  27044   ROST ;Proc ess patien ts from se lected ros ter
  27045   "RTN","VPR ROS6",78,0 )
  27046    K VPRLIST 2,VPRBLIST  S (VPRLIS T2,VPRBLIS T)="" ; --  kcm added  comma
  27047   "RTN","VPR ROS6",79,0 )
  27048    N VPR,VPR IEN,VPERR
  27049   "RTN","VPR ROS6",80,0 )
  27050    S VPRIEN= +$P(VPRX," ^",2),VPER R="",VPROU T=1,VPR="V PRBLIST"
  27051   "RTN","VPR ROS6",81,0 )
  27052    D COMPILE ^VPRROS2(. VPRZ,VPRIE N,"")
  27053   "RTN","VPR ROS6",82,0 )
  27054    M VPRBLIS T=VPRLIST2
  27055   "RTN","VPR ROS6",83,0 )
  27056    K VPROUT
  27057   "RTN","VPR ROS6",84,0 )
  27058    Q
  27059   "RTN","VPR ROS6",85,0 )
  27060    ;
  27061   "RTN","VPR ROS6",86,0 )
  27062   SPEC ;Proc ess patien ts with se lected Tre ating Spec ialty
  27063   "RTN","VPR ROS6",87,0 )
  27064    K VPRLIST 2 S VPRLIS T2=""
  27065   "RTN","VPR ROS6",88,0 )
  27066    S VPROIEN =+$P(VPRX, "^",2),VPE RR=""
  27067   "RTN","VPR ROS6",89,0 )
  27068    N DFN S D FN=0 F  S  DFN=$O(^DP T("ATR",VP ROIEN,DFN) ) Q:DFN'>0   S VPRLIS T2(DFN)=VP RIZ
  27069   "RTN","VPR ROS6",90,0 )
  27070    Q
  27071   "RTN","VPR ROS6",91,0 )
  27072    ;
  27073   "RTN","VPR ROS6",92,0 )
  27074   PROV ;Proc ess patien ts for sel ected prov ider
  27075   "RTN","VPR ROS6",93,0 )
  27076    K VPRLIST 2 S VPRLIS T2=""
  27077   "RTN","VPR ROS6",94,0 )
  27078    S VPRPIEN =+$P(VPRX, "^",2),VPE RR=""
  27079   "RTN","VPR ROS6",95,0 )
  27080    N DFN S D FN=0 F  S  DFN=$O(^DP T("APR",VP RPIEN,DFN) ) Q:DFN'>0   S VPRLIS T2(DFN)=""
  27081   "RTN","VPR ROS6",96,0 )
  27082    Q
  27083   "RTN","VPR ROS6",97,0 )
  27084    ;
  27085   "RTN","VPR ROS6",98,0 )
  27086   PXRM ;Proc ess patien ts for sel ected pane l
  27087   "RTN","VPR ROS6",99,0 )
  27088    K VPRLIST 2 S VPRLIS T2=""
  27089   "RTN","VPR ROS6",100, 0)
  27090    S VPRPIEN =+$P(VPRX, "^",2),VPE RR=""
  27091   "RTN","VPR ROS6",101, 0)
  27092    S VPRC=VP RPIEN,VPRL IEN=$P(^VP ROSTER(VPR IEN,0),"^" ,1),VPRPNM E=$P(^VPRO STER(VPRIE N,0),"^",6 ) I VPRPNM E="" S VPR PNME=VPRRN AME,$P(^VP ROSTER(VPR IEN,0),U,6 )=VPRRNAME
  27093   "RTN","VPR ROS6",102, 0)
  27094    S VPRPAT= "" D RUNLI ST^VPRROS5 (.VPRPAT,V PRLIEN,VPR PNME,0,1)
  27095   "RTN","VPR ROS6",103, 0)
  27096    S VPRII=0  F  S VPRI I=$O(VPRPA T(VPRC,VPR II)) Q:VPR II'>0  S D FN=VPRPAT( VPRC,VPRII ),VPRLIST2 (DFN)=VPRI Z
  27097   "RTN","VPR ROS6",104, 0)
  27098    Q
  27099   "RTN","VPR ROS6",105, 0)
  27100    ;
  27101   "RTN","VPR ROS6",106, 0)
  27102   UNION ;Add  to existi ng list
  27103   "RTN","VPR ROS6",107, 0)
  27104    S VPRII=0  F  S VPRI I=$O(VPRLI ST2(VPRII) ) Q:VPRII' >0  S VPRL IST(VPRII) =VPRLIST2( VPRII)
  27105   "RTN","VPR ROS6",108, 0)
  27106    Q
  27107   "RTN","VPR ROS6",109, 0)
  27108    ;
  27109   "RTN","VPR ROS6",110, 0)
  27110   INTER ;Int ersect wit h existing  list
  27111   "RTN","VPR ROS6",111, 0)
  27112    S VPRII=0  F  S VPRI I=$O(VPRLI ST(VPRII))  Q:VPRII'> 0  D
  27113   "RTN","VPR ROS6",112, 0)
  27114    . I '$D(V PRLIST2(VP RII)) K VP RLIST(VPRI I)
  27115   "RTN","VPR ROS6",113, 0)
  27116    Q
  27117   "RTN","VPR ROS6",114, 0)
  27118    ;
  27119   "RTN","VPR ROS6",115, 0)
  27120   DIFF ;Remo ve patient s from thi s source t hat we hav e so far
  27121   "RTN","VPR ROS6",116, 0)
  27122    S VPRII=0  F  S VPRI I=$O(VPRLI ST2(VPRII) ) Q:VPRII' >0  D
  27123   "RTN","VPR ROS6",117, 0)
  27124    . K VPRLI ST(VPRII)
  27125   "RTN","VPR ROS6",118, 0)
  27126    Q
  27127   "RTN","VPR ROS6",119, 0)
  27128    ;
  27129   "RTN","VPR ROS6",120, 0)
  27130   GENPAT(VPR ID) ;
  27131   "RTN","VPR ROS6",121, 0)
  27132    N DFN,DIC ,DR,DIE,DA ,NODE,VPRN UM
  27133   "RTN","VPR ROS6",122, 0)
  27134    S DFN=0
  27135   "RTN","VPR ROS6",123, 0)
  27136    S VPRNUM= 0
  27137   "RTN","VPR ROS6",124, 0)
  27138    K ^VPROST ER(VPRID,4 ) S ^VPROS TER(VPRID, 4,0)="^561 .23P^^"
  27139   "RTN","VPR ROS6",125, 0)
  27140    F  S DFN= $O(VPRLIST (DFN)) Q:D FN'>0  D
  27141   "RTN","VPR ROS6",126, 0)
  27142    . S VPRNU M=VPRNUM+1  S ^VPROST ER(VPRID,4 ,VPRNUM,0) =DFN_"^"_V PRLIST(DFN ),^VPROSTE R(VPRID,4, "B",DFN,VP RNUM)="",^ VPROSTER(" AB",DFN,VP RID,VPRNUM )=""
  27143   "RTN","VPR ROS6",127, 0)
  27144    Q
  27145   "RTN","VPR ROS7")
  27146   0^62^B2383 8606
  27147   "RTN","VPR ROS7",1,0)
  27148   VPRROS7 ;S LC/GRR --  Get Roster  identific ation for  patient(s)  ;4/24/201 2
  27149   "RTN","VPR ROS7",2,0)
  27150    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;AUG  17, 2011;B uild 283
  27151   "RTN","VPR ROS7",3,0)
  27152   GET(VPR,VP RARRAY) ;;  Previews  what a ros ter would  look like  as defined
  27153   "RTN","VPR ROS7",4,0)
  27154    ;;  Calle d by the G UI Roster  Builder
  27155   "RTN","VPR ROS7",5,0)
  27156    ;; Input  - VPRARRAY  - contain s roster d ata entere d thru GUI
  27157   "RTN","VPR ROS7",6,0)
  27158    K VPRLIST ,VPRLIST2
  27159   "RTN","VPR ROS7",7,0)
  27160    N %,BEG,D A,DIDEL,DI E,DOB,SSN, DR,END,GEN DER,ICN,NA ME,VPRC,VP RCIEN,VPRD IS,VPRDNAM E,VPRDOB,V PRDT,VPRII I,VPRLIEN, VPROIEN,VP ROWNID
  27161   "RTN","VPR ROS7",8,0)
  27162    N VPROWNN M,VPRPAT,V PRPIEN,VPR PNME,VPRRC NT,VPRRID, VPRTEXT,VP RTIEN,VPRL ST,VPRVAR, VPRVER,VPR WIEN,VPRWN AME,VPRZ,X ,Y
  27163   "RTN","VPR ROS7",9,0)
  27164    N VPRFILT ,VPRI,VPRN LIST,VPRSR CID,VPRTAG ,VPRTLST,V PRY,VPRTYP E,ZZ,DFN,I EN,VPERR,V PRICN,VPRO P,VPRPNAME ,VPRRNAME
  27165   "RTN","VPR ROS7",10,0 )
  27166    N VPRSYS  S VPRSYS=$ $GET^XPAR( "SYS","VPR  SYSTEM NA ME")
  27167   "RTN","VPR ROS7",11,0 )
  27168    S (VPRLIS T,VPRFILT, VPRTYPE,VP ROP,VPRLIS T2,VPERR)= "",VPRI=0
  27169   "RTN","VPR ROS7",12,0 )
  27170    S VPR=$NA (^TMP($J," VPROSTER") ) ; kcm --  moved thi s here so  VPR gets d efined
  27171   "RTN","VPR ROS7",13,0 )
  27172    K ^TMP($J ,"VPROSTER ")
  27173   "RTN","VPR ROS7",14,0 )
  27174    I $O(VPRA RRAY(""))= "" S @VPR@ (1)="0^No  patient da ta passed"  Q
  27175   "RTN","VPR ROS7",15,0 )
  27176    D NOW^%DT C S VPRDT= %
  27177   "RTN","VPR ROS7",16,0 )
  27178    S VPRVER= "<results  version='" _$P($T(VPR ROS7+1),"; ",3)_"'>"
  27179   "RTN","VPR ROS7",17,0 )
  27180    D ADD(VPR VER)
  27181   "RTN","VPR ROS7",18,0 )
  27182    S VPRZ=""  F  S VPRZ =$O(VPRARR AY(VPRZ))  Q:VPRZ=""   D
  27183   "RTN","VPR ROS7",19,0 )
  27184    . S DFN=$ P(VPRARRAY (VPRZ),"^" ,1),VPRPNA ME=$P(VPRA RRAY(VPRZ) ,"^",2),VP RPNAME=$$E SC^VPRD(VP RPNAME),VP RICN=$P(VP RARRAY(VPR Z),"^",3)
  27185   "RTN","VPR ROS7",20,0 )
  27186    . S ICN=$ $GETICN^MP IF001(DFN)
  27187   "RTN","VPR ROS7",21,0 )
  27188    . S NAME= $P(^DPT(DF N,0),"^",1 ),GENDER=$ P(^DPT(DFN ,0),"^",2) ,SSN=$P(^D PT(DFN,0), "^",9),DOB =$P(^DPT(D FN,0),"^", 3),VPRDOB= $$FMTHL7^X LFDT(DOB)
  27189   "RTN","VPR ROS7",22,0 )
  27190    . S Y="<p atient nam e='"_NAME_ "' gender= '"_GENDER_ "' dob='"_ VPRDOB_"'  ssn='"_SSN _"' id='"_ DFN_$S(ICN :"' icn='" _ICN,1:"") _"' />" D  ADD(Y)
  27191   "RTN","VPR ROS7",23,0 )
  27192    . S IEN=" " F  S IEN =$O(^VPROS TER("AB",D FN,IEN)) Q :IEN=""  D
  27193   "RTN","VPR ROS7",24,0 )
  27194    . . S VPR RID=IEN,VP RRNAME=$P( $G(^VPROST ER(VPRRID, 0)),"^",1) ,VPRRNAME= $$ESC^VPRD (VPRRNAME)
  27195   "RTN","VPR ROS7",25,0 )
  27196    . . S VPR TEXT="<ros ter ien='" _VPRRID_"'  rosterNam e='"_VPRRN AME_"'/>"  D ADD(VPRT EXT)
  27197   "RTN","VPR ROS7",26,0 )
  27198    S VPRTEXT ="</result s>" D ADD( VPRTEXT)
  27199   "RTN","VPR ROS7",27,0 )
  27200    Q
  27201   "RTN","VPR ROS7",28,0 )
  27202    ;
  27203   "RTN","VPR ROS7",29,0 )
  27204   ADD(X) ; - - Add a li ne @VPR@(n )=X
  27205   "RTN","VPR ROS7",30,0 )
  27206    S VPRI=$G (VPRI)+1
  27207   "RTN","VPR ROS7",31,0 )
  27208    S @VPR@(V PRI)=X
  27209   "RTN","VPR ROS7",32,0 )
  27210    Q
  27211   "RTN","VPR ROS7",33,0 )
  27212    ;
  27213   "RTN","VPR ROS7",34,0 )
  27214   TEST ;TEMP ORARY
  27215   "RTN","VPR ROS7",35,0 )
  27216    S VPRARRA Y(0)="1008 45^AVIVAPA TIENT,FOUR ^"
  27217   "RTN","VPR ROS7",36,0 )
  27218    S VPRARRA Y(1)="1008 50^AVIVAPA TIENT,TEN^ "
  27219   "RTN","VPR ROS7",37,0 )
  27220    D GET(.VP R,.VPRARRA Y)
  27221   "RTN","VPR ROS7",38,0 )
  27222    Q
  27223   "RTN","VPR ROS7",39,0 )
  27224    ;
  27225   "RTN","VPR ROS7",40,0 )
  27226   TESTJ ;TEM PORARY
  27227   "RTN","VPR ROS7",41,0 )
  27228    S VPRARRA Y(0)="1008 45^AVIVAPA TIENT,FOUR ^"
  27229   "RTN","VPR ROS7",42,0 )
  27230    S VPRARRA Y(1)="1008 50^AVIVAPA TIENT,TEN^ "
  27231   "RTN","VPR ROS7",43,0 )
  27232    D GETJ(.V PR,.VPRARR AY)
  27233   "RTN","VPR ROS7",44,0 )
  27234    Q
  27235   "RTN","VPR ROS7",45,0 )
  27236    ;
  27237   "RTN","VPR ROS7",46,0 )
  27238   GETJ(VPR,V PRARRAY) ; Get Roster s which ar e in selec ted patien t(s)
  27239   "RTN","VPR ROS7",47,0 )
  27240    ;output i n JSON obj ect contai ns patient  informati on and all  rosters p atient is  currently  in
  27241   "RTN","VPR ROS7",48,0 )
  27242    S VPR=$NA (^TMP($J," VPROSTER") ) ; kcm --  moved thi s here so  VPR gets d efined
  27243   "RTN","VPR ROS7",49,0 )
  27244    N VPRI,VP RDT,VPRZ,D FN,VPRRNAM E,VPRICN,N AME,SSN,DO B,VPRDOB,P AT,VPRRID, X,Y
  27245   "RTN","VPR ROS7",50,0 )
  27246    K ^TMP($J ,"VPROSTER ")
  27247   "RTN","VPR ROS7",51,0 )
  27248    I $O(VPRA RRAY(""))= "" S @VPR@ (1)="0^No  patient da ta passed"  Q
  27249   "RTN","VPR ROS7",52,0 )
  27250    D NOW^%DT C S VPRDT= %
  27251   "RTN","VPR ROS7",53,0 )
  27252    S VPRI=0
  27253   "RTN","VPR ROS7",54,0 )
  27254    S VPRZ=""  F  S VPRZ =$O(VPRARR AY(VPRZ))  Q:VPRZ=""   D
  27255   "RTN","VPR ROS7",55,0 )
  27256    . S DFN=$ P(VPRARRAY (VPRZ),"^" ,1),VPRPNA ME=$P(VPRA RRAY(VPRZ) ,"^",2),VP RPNAME=$$E SC^VPRD(VP RPNAME),VP RICN=$P(VP RARRAY(VPR Z),"^",3)
  27257   "RTN","VPR ROS7",56,0 )
  27258    . S ICN=$ $GETICN^MP IF001(DFN)
  27259   "RTN","VPR ROS7",57,0 )
  27260    . S NAME= $P(^DPT(DF N,0),"^",1 ),GENDER=$ P(^DPT(DFN ,0),"^",2) ,SSN=$P(^D PT(DFN,0), "^",9),DOB =$P(^DPT(D FN,0),"^", 3),VPRDOB= $$JSONDT^V PRUTILS(DO B)
  27261   "RTN","VPR ROS7",58,0 )
  27262    . S PAT(" familyName ")=$P(NAME ,",",1),PA T("givenNa mes")=$P(N AME,",",2, 99),PAT("s sn")=SSN,P AT("localI d")=DFN
  27263   "RTN","VPR ROS7",59,0 )
  27264    . S X=GEN DER S PAT( "genderCod e")="urn:v a:pat-gend er:"_X,PAT ("genderNa me")=$$NAM E^VPRDJ00( X,"gender" )
  27265   "RTN","VPR ROS7",60,0 )
  27266    . S PAT(" dateOfBirt h")=VPRDOB ,PAT("uid" )=$$SETUID ^VPRUTILS( "pat",DFN, DFN,"")
  27267   "RTN","VPR ROS7",61,0 )
  27268    . S IEN=" " F  S IEN =$O(^VPROS TER("AB",D FN,IEN)) Q :IEN=""  D
  27269   "RTN","VPR ROS7",62,0 )
  27270    . . S VPR RID=IEN,VP RRNAME=$P( $G(^VPROST ER(VPRRID, 0)),"^",1) ,VPRRNAME= $$ESC^VPRD (VPRRNAME)
  27271   "RTN","VPR ROS7",63,0 )
  27272    . . S PAT ("roster", IEN,"local Id")=IEN,P AT("roster ",IEN,"uid ")=$$SETUI D^VPRUTILS ("roster", "",IEN,"")
  27273   "RTN","VPR ROS7",64,0 )
  27274    . . S PAT ("roster", IEN,"roste rName")=VP RRNAME
  27275   "RTN","VPR ROS7",65,0 )
  27276    I $D(PAT) >9 D ADDJ
  27277   "RTN","VPR ROS7",66,0 )
  27278    Q
  27279   "RTN","VPR ROS7",67,0 )
  27280    ;
  27281   "RTN","VPR ROS7",68,0 )
  27282   ADDJ ;
  27283   "RTN","VPR ROS7",69,0 )
  27284    N VPRY,ER R
  27285   "RTN","VPR ROS7",70,0 )
  27286    D ENCODE^ VPRJSON("P AT","VPRY" ,"ERR")
  27287   "RTN","VPR ROS7",71,0 )
  27288    I $D(VPRY ) D
  27289   "RTN","VPR ROS7",72,0 )
  27290    . D:VPRI  COMMA(VPRI )
  27291   "RTN","VPR ROS7",73,0 )
  27292    . S VPRI= VPRI+1 M @ VPR@(VPRI) =VPRY
  27293   "RTN","VPR ROS7",74,0 )
  27294    Q
  27295   "RTN","VPR ROS7",75,0 )
  27296    ;
  27297   "RTN","VPR ROS7",76,0 )
  27298   COMMA(I) ; ; -- add c omma betwe en items
  27299   "RTN","VPR ROS7",77,0 )
  27300    N J S J=+ $O(@VPR@(I ,"A"),-1)  ;last sub- node for i tem I
  27301   "RTN","VPR ROS7",78,0 )
  27302    S J=J+1,@ VPR@(I,J)= ","
  27303   "RTN","VPR ROS7",79,0 )
  27304    Q
  27305   "RTN","VPR ROS7",80,0 )
  27306    ;
  27307   "RTN","VPR ROS7",81,0 )
  27308   SUBS(VPR,S YS,ON,LIST ) ; -- Un/ Subscribe  to Patient  Data Moni tor
  27309   "RTN","VPR ROS7",82,0 )
  27310    ; RPC = V PR SUBSCRI BE ROSTERS
  27311   "RTN","VPR ROS7",83,0 )
  27312    N DA,I,ID ,HDR,VPRI
  27313   "RTN","VPR ROS7",84,0 )
  27314    S SYS=$G( SYS),ON=+$ G(ON) Q:'$ L(SYS)
  27315   "RTN","VPR ROS7",85,0 )
  27316    S DA=$$FI ND^VPRPATS (SYS) Q:DA <1
  27317   "RTN","VPR ROS7",86,0 )
  27318    S VPR=$NA (^TMP("VPR ",$J)) K @ VPR
  27319   "RTN","VPR ROS7",87,0 )
  27320    ;S:'$D(^X TMP("VPROS ")) ^XTMP( "VPROS",0) ="3991231^ "_DT_"^VPR  Patient D ata Monito r"
  27321   "RTN","VPR ROS7",88,0 )
  27322    ;
  27323   "RTN","VPR ROS7",89,0 )
  27324    ; loop th rough LIST (n) = 'id'
  27325   "RTN","VPR ROS7",90,0 )
  27326    D ADD("<r osters>")
  27327   "RTN","VPR ROS7",91,0 )
  27328    S I="" F   S I=$O(LI ST(I)) Q:I =""  S ID= LIST(I) D
  27329   "RTN","VPR ROS7",92,0 )
  27330    . I ID<1! '$D(^VPROS TER(ID)) D  RET(ID,"e rror") Q
  27331   "RTN","VPR ROS7",93,0 )
  27332    . I ON D   Q
  27333   "RTN","VPR ROS7",94,0 )
  27334    .. S:'$D( ^VPR(560,D A,2,ID,0))  HDR=$G(^V PR(560,DA, 2,0)),^(0) ="^560.02P ^"_ID_U_($ P(HDR,U,4) +1)
  27335   "RTN","VPR ROS7",95,0 )
  27336    .. S ^VPR (560,DA,2, ID,0)=ID_U _ON,^VPR(5 60,"AROS", ID,DA)=""
  27337   "RTN","VPR ROS7",96,0 )
  27338    .. D RET( ID,"on") ; S ^XTMP("V PROS",ID)= ON
  27339   "RTN","VPR ROS7",97,0 )
  27340    . ; else,  remove pa tient trac king info  from ^XTMP
  27341   "RTN","VPR ROS7",98,0 )
  27342    . S:$D(^V PR(560,DA, 2,ID,0)) $ P(^(0),U,2 )=0
  27343   "RTN","VPR ROS7",99,0 )
  27344    . K ^VPR( 560,"AROS" ,ID,DA) ;I  '$D(^VPR( 560,"AROS" ,ID)) K ^X TMP("VPROS ",ID)
  27345   "RTN","VPR ROS7",100, 0)
  27346    . D RET(I D,"off")
  27347   "RTN","VPR ROS7",101, 0)
  27348    D ADD("</ rosters>")
  27349   "RTN","VPR ROS7",102, 0)
  27350    Q
  27351   "RTN","VPR ROS7",103, 0)
  27352    ;
  27353   "RTN","VPR ROS7",104, 0)
  27354   RET(ID,STS ) ; -- add  XML node  for roster  ID update  subscript ion
  27355   "RTN","VPR ROS7",105, 0)
  27356    N Y S Y=" <roster id ='"_$G(ID)
  27357   "RTN","VPR ROS7",106, 0)
  27358    S Y=Y_"'  subscribe= '"_$G(STS) _"' />"
  27359   "RTN","VPR ROS7",107, 0)
  27360    D ADD(Y)
  27361   "RTN","VPR ROS7",108, 0)
  27362    Q
  27363   "RTN","VPR SR")
  27364   0^4^B40628 8
  27365   "RTN","VPR SR",1,0)
  27366   VPRSR ;SLC /MKB -- Su rgery inte rface
  27367   "RTN","VPR SR",2,0)
  27368    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  27369   "RTN","VPR SR",3,0)
  27370    ;
  27371   "RTN","VPR SR",4,0)
  27372    ; Support ed by DBIA  #4750
  27373   "RTN","VPR SR",5,0)
  27374    ;
  27375   "RTN","VPR SR",6,0)
  27376    ; ------- ---------  Update Tri ggers ---- ---------- --
  27377   "RTN","VPR SR",7,0)
  27378    ;
  27379   "RTN","VPR SR",8,0)
  27380   NEW(IEN,DF N,STS) ; - - new surg ery reques t [from SR OERR]
  27381   "RTN","VPR SR",9,0)
  27382    S IEN=+$G (IEN),DFN= +$G(DFN) Q :DFN<1
  27383   "RTN","VPR SR",10,0)
  27384    D SR^VPRE VNT(DFN,IE N)
  27385   "RTN","VPR SR",11,0)
  27386    Q
  27387   "RTN","VPR SR",12,0)
  27388    ;
  27389   "RTN","VPR SR",13,0)
  27390   UPD(IEN,DF N,STS) ; - - updated  surgery re quest [fro m SROERR0]
  27391   "RTN","VPR SR",14,0)
  27392    S IEN=+$G (IEN),DFN= +$G(DFN) Q :DFN<1
  27393   "RTN","VPR SR",15,0)
  27394    D SR^VPRE VNT(DFN,IE N)
  27395   "RTN","VPR SR",16,0)
  27396    Q
  27397   "RTN","VPR SR",17,0)
  27398    ;
  27399   "RTN","VPR SR",18,0)
  27400   DEL(IEN,DF N) ; -- de lete surge ry request  [from SRO ERR]
  27401   "RTN","VPR SR",19,0)
  27402    S IEN=+$G (IEN),DFN= +$G(DFN) Q :DFN<1
  27403   "RTN","VPR SR",20,0)
  27404    D SR^VPRE VNT(DFN,IE N,"@")
  27405   "RTN","VPR SR",21,0)
  27406    Q
  27407   "RTN","VPR TRPC")
  27408   0^63^B3739 499
  27409   "RTN","VPR TRPC",1,0)
  27410   VPRTRPC ;S LC/AGP - G eneric RPC  controlle r for VPR  ; 7/30/13  3:29pm
  27411   "RTN","VPR TRPC",2,0)
  27412    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  27413   "RTN","VPR TRPC",3,0)
  27414    ;
  27415   "RTN","VPR TRPC",4,0)
  27416    ;
  27417   "RTN","VPR TRPC",5,0)
  27418   RPC(VPRRES ,PARAMS) ;  Process r equest via  RPC inste ad of CSP
  27419   "RTN","VPR TRPC",6,0)
  27420    N X,REQ,V PRCNT,VPRS ITE,VPRUSE R,VPRDBUG, VPRSTA
  27421   "RTN","VPR TRPC",7,0)
  27422    ;S VPRXML =$NA(^TMP( $J,"VPR RE SULTS")) K  @VPRXML
  27423   "RTN","VPR TRPC",8,0)
  27424    S VPRCNT= 0
  27425   "RTN","VPR TRPC",9,0)
  27426    ;S VPRUSE R=DUZ,VPRS ITE=DUZ(2) ,VPRSTA=$$ STA^XUAF4( DUZ(2))
  27427   "RTN","VPR TRPC",10,0 )
  27428    S X="" F   S X=$O(PA RAMS(X)) Q :X=""  S R EQ(X,1)=PA RAMS(X)
  27429   "RTN","VPR TRPC",11,0 )
  27430    ;
  27431   "RTN","VPR TRPC",12,0 )
  27432   COMMON ; C ome here f or both CS P and RPC  Mode
  27433   "RTN","VPR TRPC",13,0 )
  27434    ; 
  27435   "RTN","VPR TRPC",14,0 )
  27436    N CMD
  27437   "RTN","VPR TRPC",15,0 )
  27438    S CMD=$G( REQ("comma nd",1))
  27439   "RTN","VPR TRPC",16,0 )
  27440    ;
  27441   "RTN","VPR TRPC",17,0 )
  27442    I CMD="te stRPC" D   G OUT
  27443   "RTN","VPR TRPC",18,0 )
  27444    . D TESTR PC(.VPRRES ,$$VAL("va lue"))
  27445   "RTN","VPR TRPC",19,0 )
  27446    ;
  27447   "RTN","VPR TRPC",20,0 )
  27448    I CMD="im portJson"  D IMPJSON^ VPRTRPC1(. VPRRES,.PA RAMS)
  27449   "RTN","VPR TRPC",21,0 )
  27450    ;
  27451   "RTN","VPR TRPC",22,0 )
  27452    I CMD="te stDelay" D  DELAY^VPR TRPC1(.VPR RES,.PARAM S)
  27453   "RTN","VPR TRPC",23,0 )
  27454    ;
  27455   "RTN","VPR TRPC",24,0 )
  27456    I CMD="sa veData" D  SAVE^VPRTR PC1(.VPRRE S,$$VAL("p atient"),$ $VAL("user "),$$VAL(" domain"),$ $VAL("num" ),$$VAL("s ystem"),$$ VAL("json" ))
  27457   "RTN","VPR TRPC",25,0 )
  27458    ;
  27459   "RTN","VPR TRPC",26,0 )
  27460    I CMD="de leteData"  D DELETE^V PRTRPC1(.V PRRES,$$VA L("patient "),$$VAL(" system"),$ $VAL("json "))
  27461   "RTN","VPR TRPC",27,0 )
  27462    ;
  27463   "RTN","VPR TRPC",28,0 )
  27464    ;M ^XTMP( "AGP TEST" ,"PARAMS") =PARAMS
  27465   "RTN","VPR TRPC",29,0 )
  27466    I CMD="cl earData" D  CLEARVAL^ VPRTRPC1(. VPRRES,$$V AL("system "),$$VAL(" patient"), $$VAL("beg "),$$VAL(" end"),$$VA L("json"))
  27467   "RTN","VPR TRPC",30,0 )
  27468    ;
  27469   "RTN","VPR TRPC",31,0 )
  27470    I CMD="ge tFields" D  GETFLDS^V PRTRPC1(.V PRRES)
  27471   "RTN","VPR TRPC",32,0 )
  27472    ;
  27473   "RTN","VPR TRPC",33,0 )
  27474   OUT ;
  27475   "RTN","VPR TRPC",34,0 )
  27476    I '$D(VPR RES) S VPR RES=""
  27477   "RTN","VPR TRPC",35,0 )
  27478   END Q
  27479   "RTN","VPR TRPC",36,0 )
  27480    ;
  27481   "RTN","VPR TRPC",37,0 )
  27482   VAL(X) ; r eturn valu e from req uest
  27483   "RTN","VPR TRPC",38,0 )
  27484    Q $G(REQ( X,1))
  27485   "RTN","VPR TRPC",39,0 )
  27486    ;
  27487   "RTN","VPR TRPC",40,0 )
  27488   TESTRPC(RE SULT,VALUE ) ;
  27489   "RTN","VPR TRPC",41,0 )
  27490    S RESULT= "result"
  27491   "RTN","VPR TRPC",42,0 )
  27492    I VALUE=" error" D A PPERROR^%Z TER("test  RPC Error" ) Q
  27493   "RTN","VPR TRPC",43,0 )
  27494    I VALUE=" wait" H 60
  27495   "RTN","VPR TRPC",44,0 )
  27496    Q
  27497   "RTN","VPR TRPC",45,0 )
  27498    ;
  27499   "RTN","VPR TRPC1")
  27500   0^64^B4151 8784
  27501   "RTN","VPR TRPC1",1,0 )
  27502   VPRTRPC1 ;  SLC/AGP -  Process O rder Reque st from AV IVA System . ; 7/30/1 3 3:29pm
  27503   "RTN","VPR TRPC1",2,0 )
  27504    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  27505   "RTN","VPR TRPC1",3,0 )
  27506    Q
  27507   "RTN","VPR TRPC1",4,0 )
  27508    ;
  27509   "RTN","VPR TRPC1",5,0 )
  27510   GETFLDS(RE SULT) ;
  27511   "RTN","VPR TRPC1",6,0 )
  27512    N ARRAY,C NT,FCNT,FI ELDS,NUM,T YPE,VPRP,V PRTYPE,X
  27513   "RTN","VPR TRPC1",7,0 )
  27514    S CNT=0
  27515   "RTN","VPR TRPC1",8,0 )
  27516    ;F TYPE=" vs","prob" ,"art","or der","med" ,"cons","p roc","obs" ,"lab","ra d","surger y","tiu"," mha","imm" ,"pov","sk in","exam" ,"cpt","ed ","factor" ,"appt","v isit","ptf " D
  27517   "RTN","VPR TRPC1",9,0 )
  27518    S VPRTYPE =$$ALL^VPR DJ
  27519   "RTN","VPR TRPC1",10, 0)
  27520    F VPRP=1: 1:$L(VPRTY PE,";") S  TYPE=$P(VP RTYPE,";", VPRP) I $L (TYPE) D
  27521   "RTN","VPR TRPC1",11, 0)
  27522    .S CNT=CN T+1
  27523   "RTN","VPR TRPC1",12, 0)
  27524    .S ARRAY( "data",CNT ,"type","n ame")=TYPE
  27525   "RTN","VPR TRPC1",13, 0)
  27526    .S FIELDS =$$ATTR^VP RDCRC(TYPE )
  27527   "RTN","VPR TRPC1",14, 0)
  27528    .S NUM=$L (FIELDS,U)
  27529   "RTN","VPR TRPC1",15, 0)
  27530    .S FCNT=0
  27531   "RTN","VPR TRPC1",16, 0)
  27532    .F X=1:1: NUM D
  27533   "RTN","VPR TRPC1",17, 0)
  27534    ..I $P(FI ELDS,U,X)= "" Q
  27535   "RTN","VPR TRPC1",18, 0)
  27536    ..S FCNT= FCNT+1
  27537   "RTN","VPR TRPC1",19, 0)
  27538    ..S ARRAY ("data",CN T,"type"," fields",FC NT,"field" )=$P(FIELD S,U,X)
  27539   "RTN","VPR TRPC1",20, 0)
  27540    D ENCODE^ VPRJSON("A RRAY","RES ULT","ERRO R")
  27541   "RTN","VPR TRPC1",21, 0)
  27542    ;I $D(ERR OR) ZW ERR OR
  27543   "RTN","VPR TRPC1",22, 0)
  27544    Q
  27545   "RTN","VPR TRPC1",23, 0)
  27546    ;
  27547   "RTN","VPR TRPC1",24, 0)
  27548   TESTRPC(OU T,PARAMS)  ;
  27549   "RTN","VPR TRPC1",25, 0)
  27550    ;K ^XTMP( "ZZVPR PAR AMS"),^XTM P("ZZVPR J SON") ; KC M -- comme nted out f or XINDEX
  27551   "RTN","VPR TRPC1",26, 0)
  27552    ;M ^XTMP( "ZZVPR JSO N")=JSON
  27553   "RTN","VPR TRPC1",27, 0)
  27554    ;M ^XTMP( "ZZVPR PAR AMS")=PARA MS ; KCM - - commente d out for  XINDEX
  27555   "RTN","VPR TRPC1",28, 0)
  27556    Q
  27557   "RTN","VPR TRPC1",29, 0)
  27558    ;
  27559   "RTN","VPR TRPC1",30, 0)
  27560   CLEARVAL(R ESULT,SYS, PAT,BEG,EN D,JSON) ;
  27561   "RTN","VPR TRPC1",31, 0)
  27562    N BDATE,B NUM,DATE,E DATE,ENUM, LAST,NODE, SUB,X,LAST
  27563   "RTN","VPR TRPC1",32, 0)
  27564    D DELSYS( SYS)
  27565   "RTN","VPR TRPC1",33, 0)
  27566    S BDATE=$ P(BEG,":") ,BNUM=$P(B EG,":",2)
  27567   "RTN","VPR TRPC1",34, 0)
  27568    S EDATE=$ P(END,":") ,ENUM=$P(E ND,":",2)
  27569   "RTN","VPR TRPC1",35, 0)
  27570    S SUB="VP R-"_BDATE
  27571   "RTN","VPR TRPC1",36, 0)
  27572    ;handle c leaning ou t the ^xtm p for the  same date  range
  27573   "RTN","VPR TRPC1",37, 0)
  27574    I BDATE=E DATE D  Q
  27575   "RTN","VPR TRPC1",38, 0)
  27576    .F X=BNUM :1:ENUM I  $P(^XTMP(" VPR-"_BDAT E,X),U)=PA T K ^XTMP( "VPR-"_BDA TE,X)
  27577   "RTN","VPR TRPC1",39, 0)
  27578    ;
  27579   "RTN","VPR TRPC1",40, 0)
  27580    F  S SUB= $O(^XTMP(S UB)) D  Q: SUB=""!($$ END(SUB,ED ATE)=1)
  27581   "RTN","VPR TRPC1",41, 0)
  27582    .;handle  date less  then end d ate but da te equal s tart date
  27583   "RTN","VPR TRPC1",42, 0)
  27584    .S DATE=$ P(SUB,"-", 2) I DATE< EDATE,DATE =BDATE D   Q
  27585   "RTN","VPR TRPC1",43, 0)
  27586    ..S LAST= $O(^XTMP(S UB,""),-1)
  27587   "RTN","VPR TRPC1",44, 0)
  27588    ..F X=BNU M:1:LAST I  $P(^XTMP( SUB,X),U)= PAT K ^XTM P(SUB,X)
  27589   "RTN","VPR TRPC1",45, 0)
  27590    .;
  27591   "RTN","VPR TRPC1",46, 0)
  27592    .;handle  date great er then st art date a nd less th en end dat e
  27593   "RTN","VPR TRPC1",47, 0)
  27594    .I DATE<E DATE,DATE> BDATE D  Q
  27595   "RTN","VPR TRPC1",48, 0)
  27596    ..S LAST= $O(^XTMP(S UB,""),-1)
  27597   "RTN","VPR TRPC1",49, 0)
  27598    ..F X=1:1 :LAST I $P (^XTMP(SUB ,X),U)=PAT  K ^XTMP(S UB,X)
  27599   "RTN","VPR TRPC1",50, 0)
  27600    .;
  27601   "RTN","VPR TRPC1",51, 0)
  27602    .;S LAST= $O(^XTMP(S UB,""),-1)
  27603   "RTN","VPR TRPC1",52, 0)
  27604    .;assume  date equal  stop date  and great er then st art date
  27605   "RTN","VPR TRPC1",53, 0)
  27606    .F X=1:1: ENUM I $P( ^XTMP(SUB, X),U)=PAT  K ^XTMP(SU B,X)
  27607   "RTN","VPR TRPC1",54, 0)
  27608    ;S LAST=$ O(^XTMP("V PR-"_DATE, ""),-1)
  27609   "RTN","VPR TRPC1",55, 0)
  27610    ;F X=NUM: 1:LAST K ^ XTMP("VPR- "_DATE,X)
  27611   "RTN","VPR TRPC1",56, 0)
  27612    ;Need to  iterate js on node an d delete e ntries tha t were mar ked as ent ered in er ror (for e xample  Vi tals)
  27613   "RTN","VPR TRPC1",57, 0)
  27614    ;This res et the fre shness XTM P. Should  this be in  it own RP C call?
  27615   "RTN","VPR TRPC1",58, 0)
  27616    ;K ^XTMP( "VPR-"_DT)  M ^XTMP(" VPR-"_DT)= ^XTMP("VPR  BACKUP")  K ^XTMP("V PR BACKUP" )
  27617   "RTN","VPR TRPC1",59, 0)
  27618    Q
  27619   "RTN","VPR TRPC1",60, 0)
  27620   END(NODE,E DATE) ;
  27621   "RTN","VPR TRPC1",61, 0)
  27622    N DATE
  27623   "RTN","VPR TRPC1",62, 0)
  27624    S DATE=$P (NODE,"-", 2)
  27625   "RTN","VPR TRPC1",63, 0)
  27626    I DATE'>E DATE Q 0
  27627   "RTN","VPR TRPC1",64, 0)
  27628    Q 1
  27629   "RTN","VPR TRPC1",65, 0)
  27630    ;
  27631   "RTN","VPR TRPC1",66, 0)
  27632   DELETE(RES ULT,PAT,SY S,JSON) ;
  27633   "RTN","VPR TRPC1",67, 0)
  27634    N CNT,DA, DIK,ERROR, FILENUM,GL OBAL
  27635   "RTN","VPR TRPC1",68, 0)
  27636    D DECODE^ VPRJSON("J SON","IN", "ERROR")
  27637   "RTN","VPR TRPC1",69, 0)
  27638    S FILENUM =IN("FILEN UM")
  27639   "RTN","VPR TRPC1",70, 0)
  27640    ;Handle f iles that  are not de leted need  to check  with Mel/J erry about  the actio n
  27641   "RTN","VPR TRPC1",71, 0)
  27642    ;I FILENU M="NOT DEL ETE NODES"  D NODELET E D POST^V PREVNT(PAT ,DOMAIN,DA ,"") Q
  27643   "RTN","VPR TRPC1",72, 0)
  27644    S GLOBAL= $$GET1^DID (FILENUM," ","","GLOB AL NAME")
  27645   "RTN","VPR TRPC1",73, 0)
  27646    S DIK=GLO BAL
  27647   "RTN","VPR TRPC1",74, 0)
  27648    S CNT=0 F   S CNT=$O (IN("ITEMS ",CNT)) Q: CNT'>0  D
  27649   "RTN","VPR TRPC1",75, 0)
  27650    .S DA=$G( IN("ITEMS" ,CNT,"IEN" ))
  27651   "RTN","VPR TRPC1",76, 0)
  27652    .D ^DIK
  27653   "RTN","VPR TRPC1",77, 0)
  27654    .D POST^V PREVNT(PAT ,"factor", DA,"@")
  27655   "RTN","VPR TRPC1",78, 0)
  27656    ;This res et the fre shness XTM P. Should  this be in  it own RP C call?
  27657   "RTN","VPR TRPC1",79, 0)
  27658    ;K ^XTMP( "VPR-"_DT)  M ^XTMP(" VPR-"_DT)= ^XTMP("VPR  BACKUP")  K ^XTMP("V PR BACKUP" )
  27659   "RTN","VPR TRPC1",80, 0)
  27660    Q
  27661   "RTN","VPR TRPC1",81, 0)
  27662    ;
  27663   "RTN","VPR TRPC1",82, 0)
  27664   DELAY(OUT, PARAMS) ;
  27665   "RTN","VPR TRPC1",83, 0)
  27666    N ARRAY,D ELAY
  27667   "RTN","VPR TRPC1",84, 0)
  27668    S DELAY=$ G(PARAMS(" delay"))
  27669   "RTN","VPR TRPC1",85, 0)
  27670    H DELAY
  27671   "RTN","VPR TRPC1",86, 0)
  27672    S ARRAY(" success")= "true"
  27673   "RTN","VPR TRPC1",87, 0)
  27674    D ENCODE^ VPRJSON("A RRAY","OUT ","ERROR")
  27675   "RTN","VPR TRPC1",88, 0)
  27676    I $D(ERRO R) D
  27677   "RTN","VPR TRPC1",89, 0)
  27678    .N RESULT ,TXT K OUT
  27679   "RTN","VPR TRPC1",90, 0)
  27680    .S TXT(1) ="Problem  encoding j son output "
  27681   "RTN","VPR TRPC1",91, 0)
  27682    .D SETERR OR^VPRUTIL S(.RESULT, .ERROR,.TX T,.ARRAY)
  27683   "RTN","VPR TRPC1",92, 0)
  27684    .D ENCODE ^VPRJSON(" RESULT","O UT","ERROR ")
  27685   "RTN","VPR TRPC1",93, 0)
  27686    Q
  27687   "RTN","VPR TRPC1",94, 0)
  27688    ;
  27689   "RTN","VPR TRPC1",95, 0)
  27690   DELSYS(SYS ) ;
  27691   "RTN","VPR TRPC1",96, 0)
  27692    N DA,DIK
  27693   "RTN","VPR TRPC1",97, 0)
  27694    S DA=$O(^ VPR(560,"B ",SYS,""))  I +DA'>0  Q
  27695   "RTN","VPR TRPC1",98, 0)
  27696    S DIK="^V PR(560," D  ^DIK
  27697   "RTN","VPR TRPC1",99, 0)
  27698    Q
  27699   "RTN","VPR TRPC1",100 ,0)
  27700    ;
  27701   "RTN","VPR TRPC1",101 ,0)
  27702   IMPJSON(OU T,PARAMS)  ;
  27703   "RTN","VPR TRPC1",102 ,0)
  27704    N GBL,JSO NI,DOMAIN, PATIENT,ER ROR
  27705   "RTN","VPR TRPC1",103 ,0)
  27706    S JSONI=P ARAMS("val ue"),DOMAI N=PARAMS(" domain"),P ATIENT=PAR AMS("patie ntId")
  27707   "RTN","VPR TRPC1",104 ,0)
  27708    S GBL=$NA (^TMP($J," JSON",DOMA IN,PATIENT )) ; KCM - - changed  from ^XTMP ("JSON") t o pass XIN DEX
  27709   "RTN","VPR TRPC1",105 ,0)
  27710    D DECODE^ VPRJSON("J SONI",GBL, "ERROR")
  27711   "RTN","VPR TRPC1",106 ,0)
  27712    I $D(ERRO R) D  Q
  27713   "RTN","VPR TRPC1",107 ,0)
  27714    .N RESULT ,TXT K OUT
  27715   "RTN","VPR TRPC1",108 ,0)
  27716    .S TXT(1) ="Problem  decoding j son input"
  27717   "RTN","VPR TRPC1",109 ,0)
  27718    .D SETERR OR^VPRUTIL S(.RESULT, .ERROR,.TX T,.JSONI)
  27719   "RTN","VPR TRPC1",110 ,0)
  27720    .D ENCODE ^VPRJSON(" RESULT","O UT","ERROR ")
  27721   "RTN","VPR TRPC1",111 ,0)
  27722    D ENCODE^ VPRJSON("A RRAY","OUT ","ERROR")
  27723   "RTN","VPR TRPC1",112 ,0)
  27724    Q
  27725   "RTN","VPR TRPC1",113 ,0)
  27726    ;
  27727   "RTN","VPR TRPC1",114 ,0)
  27728   GETTEAMS(O UT) ;
  27729   "RTN","VPR TRPC1",115 ,0)
  27730    N ACTPRIM ,ARRAY,CNT ,ERROR,NOD E,NUM,NAME ,PATS,SER
  27731   "RTN","VPR TRPC1",116 ,0)
  27732    S NUM=0,C NT=0 F  S  NUM=$O(^SC TM(404.51, NUM)) Q:NU M'>0  D
  27733   "RTN","VPR TRPC1",117 ,0)
  27734    .S NODE=$ G(^SCTM(40 4.51,NUM,0 )),CNT=CNT +1
  27735   "RTN","VPR TRPC1",118 ,0)
  27736    .S NAME=$ P(NODE,U), ACTPRIM=$S ($P(NODE,U ,5)=1:"tru e",1:"fals e")
  27737   "RTN","VPR TRPC1",119 ,0)
  27738    .S SER=""
  27739   "RTN","VPR TRPC1",120 ,0)
  27740    .I $P(NOD E,U,6)>6 S  SER=$P($G (^DIC(49,$ P(NODE,U,6 ),0)),U)
  27741   "RTN","VPR TRPC1",121 ,0)
  27742    .S PATS=$ $TEAMCNT^S CAPMCU1(NU M,DT)
  27743   "RTN","VPR TRPC1",122 ,0)
  27744    .S ARRAY( "data",CNT ,"name")=N AME
  27745   "RTN","VPR TRPC1",123 ,0)
  27746    .I SER'=" " S ARRAY( "data",CNT ,"service" )=SER
  27747   "RTN","VPR TRPC1",124 ,0)
  27748    .S ARRAY( "data",CNT ,"patients ")=PATS
  27749   "RTN","VPR TRPC1",125 ,0)
  27750    D ENCODE^ VPRJSON("A RRAY","OUT ","ERROR")
  27751   "RTN","VPR TRPC1",126 ,0)
  27752    I $D(ERRO R) D
  27753   "RTN","VPR TRPC1",127 ,0)
  27754    .N RESULT ,TXT K OUT
  27755   "RTN","VPR TRPC1",128 ,0)
  27756    .S TXT(1) ="Problem  encoding j son output "
  27757   "RTN","VPR TRPC1",129 ,0)
  27758    .D SETERR OR^VPRUTIL S(.RESULT, .ERROR,.TX T,.ARRAY)
  27759   "RTN","VPR TRPC1",130 ,0)
  27760    .D ENCODE ^VPRJSON(" RESULT","O UT","ERROR ")
  27761   "RTN","VPR TRPC1",131 ,0)
  27762    Q
  27763   "RTN","VPR TRPC1",132 ,0)
  27764    ;
  27765   "RTN","VPR TRPC1",133 ,0)
  27766   SAVE(RESUL T,PAT,USER ,DOMAIN,NU M,SYS,JSON ) ;
  27767   "RTN","VPR TRPC1",134 ,0)
  27768    N ERROR,I ENARRAY,LD ATE,LNUM,V ALUE
  27769   "RTN","VPR TRPC1",135 ,0)
  27770    D SETSYS( SYS,PAT)
  27771   "RTN","VPR TRPC1",136 ,0)
  27772    D DECODE^ VPRJSON("J SON","VALU E","ERROR" )
  27773   "RTN","VPR TRPC1",137 ,0)
  27774    K ^XTMP(" VPR BACKUP ")
  27775   "RTN","VPR TRPC1",138 ,0)
  27776    S LDATE=" VPR-"_DT,L NUM=0
  27777   "RTN","VPR TRPC1",139 ,0)
  27778    I '$D(^XT MP("VPR-"_ DT)) S LDA TE=$O(^XTM P("VPR-A") ,-1)
  27779   "RTN","VPR TRPC1",140 ,0)
  27780    S LNUM=$O (^XTMP(LDA TE,""),-1)
  27781   "RTN","VPR TRPC1",141 ,0)
  27782    S IENARRA Y("lastUpd ate")=$P(L DATE,"-",2 )_":"_LNUM
  27783   "RTN","VPR TRPC1",142 ,0)
  27784    M ^XTMP(" VPR BACKUP ")=^XTMP(" VPR-"_DT)
  27785   "RTN","VPR TRPC1",143 ,0)
  27786    I DOMAIN= "factor" D  HF(PAT,US ER,NUM,.VA LUE,.IENAR RAY)
  27787   "RTN","VPR TRPC1",144 ,0)
  27788    ;M RESULT =IENARRAY
  27789   "RTN","VPR TRPC1",145 ,0)
  27790    D ENCODE^ VPRJSON("I ENARRAY"," RESULT","E RROR")
  27791   "RTN","VPR TRPC1",146 ,0)
  27792    Q
  27793   "RTN","VPR TRPC1",147 ,0)
  27794    ;
  27795   "RTN","VPR TRPC1",148 ,0)
  27796   SETSYS(SYS ,PAT) ;
  27797   "RTN","VPR TRPC1",149 ,0)
  27798    N FDA,MSG ,NAME
  27799   "RTN","VPR TRPC1",150 ,0)
  27800    S NAME=$P ($G(^DPT(P AT,0)),U)  I NAME=""  Q
  27801   "RTN","VPR TRPC1",151 ,0)
  27802    S FDA(560 ,"?+1,",.0 1)=SYS
  27803   "RTN","VPR TRPC1",152 ,0)
  27804    S FDA(560 .01,"?+2,? +1,",.01)= PAT
  27805   "RTN","VPR TRPC1",153 ,0)
  27806    S FDA(560 .01,"?+2,? +1,",2)=1
  27807   "RTN","VPR TRPC1",154 ,0)
  27808    D UPDATE^ DIE("","FD A","","MSG ")
  27809   "RTN","VPR TRPC1",155 ,0)
  27810    I $D(MSG)  D  Q
  27811   "RTN","VPR TRPC1",156 ,0)
  27812    .D EN^DDI OL("Update  failed, U PDATE^DIE  returned t he followi ng error m essage.")
  27813   "RTN","VPR TRPC1",157 ,0)
  27814    .S IC="MS G"
  27815   "RTN","VPR TRPC1",158 ,0)
  27816    .F  S IC= $Q(@IC) Q: IC=""  W ! ,IC,"=",@I C
  27817   "RTN","VPR TRPC1",159 ,0)
  27818    .D EN^DDI OL("Examin e the abov e error me ssage for  the reason .")
  27819   "RTN","VPR TRPC1",160 ,0)
  27820    .H 2
  27821   "RTN","VPR TRPC1",161 ,0)
  27822    Q
  27823   "RTN","VPR TRPC1",162 ,0)
  27824    ;
  27825   "RTN","VPR TRPC1",163 ,0)
  27826   HF(PAT,USE R,NUM,VALU E,IENARRAY ) ;
  27827   "RTN","VPR TRPC1",164 ,0)
  27828    N CNT,ENC IEN,FDA,FM ,FSEC,IEN, LNUM,MSG,N AME,UID,X
  27829   "RTN","VPR TRPC1",165 ,0)
  27830    S FSEC=$P (VALUE("ui d"),":",1, 5)
  27831   "RTN","VPR TRPC1",166 ,0)
  27832    S FM=$$HL 7TFM^XLFDT (VALUE("en tered"))
  27833   "RTN","VPR TRPC1",167 ,0)
  27834    S LNUM=$O (^AUPNVHF( "A"),-1)
  27835   "RTN","VPR TRPC1",168 ,0)
  27836    S NAME=$G (VALUE("na me"))
  27837   "RTN","VPR TRPC1",169 ,0)
  27838    S IEN=$O( ^AUTTHF("B ",NAME,"") )
  27839   "RTN","VPR TRPC1",170 ,0)
  27840    S ENCIEN= $P($G(VALU E("encount erUid"))," :",6)
  27841   "RTN","VPR TRPC1",171 ,0)
  27842    S CNT=0
  27843   "RTN","VPR TRPC1",172 ,0)
  27844    F X=1:1:N UM D
  27845   "RTN","VPR TRPC1",173 ,0)
  27846    .S IENS=L NUM+X
  27847   "RTN","VPR TRPC1",174 ,0)
  27848    .S CNT=CN T+1
  27849   "RTN","VPR TRPC1",175 ,0)
  27850    .S FDA(90 00010.23," +"_IENS_", ",.01)=IEN
  27851   "RTN","VPR TRPC1",176 ,0)
  27852    .S FDA(90 00010.23," +"_IENS_", ",.03)=ENC IEN
  27853   "RTN","VPR TRPC1",177 ,0)
  27854    .S FDA(90 00010.23," +"_IENS_", ",1201)=FM
  27855   "RTN","VPR TRPC1",178 ,0)
  27856    .S FDA(90 00010.23," +"_IENS_", ",.02)=PAT
  27857   "RTN","VPR TRPC1",179 ,0)
  27858    .D UPDATE ^DIE("","F DA","","MS G")
  27859   "RTN","VPR TRPC1",180 ,0)
  27860    .I $D(MSG ) D  Q
  27861   "RTN","VPR TRPC1",181 ,0)
  27862    ..D EN^DD IOL("Updat e failed,  UPDATE^DIE  returned  the follow ing error  message.")
  27863   "RTN","VPR TRPC1",182 ,0)
  27864    ..S IC="M SG"
  27865   "RTN","VPR TRPC1",183 ,0)
  27866    ..F  S IC =$Q(@IC) Q :IC=""  W  !,IC,"=",@ IC
  27867   "RTN","VPR TRPC1",184 ,0)
  27868    ..D EN^DD IOL("Exami ne the abo ve error m essage for  the reaso n.")
  27869   "RTN","VPR TRPC1",185 ,0)
  27870    ..H 2
  27871   "RTN","VPR TRPC1",186 ,0)
  27872    .D POST^V PREVNT(PAT ,"factor", IENS)
  27873   "RTN","VPR TRPC1",187 ,0)
  27874    .S IENARR AY("FILENU M")="90000 10.23"
  27875   "RTN","VPR TRPC1",188 ,0)
  27876    .S IENARR AY("ITEMS" ,X,"IEN")= IENS
  27877   "RTN","VPR TRPC1",189 ,0)
  27878    Q
  27879   "RTN","VPR TRPC1",190 ,0)
  27880    ;
  27881   "RTN","VPR UPD")
  27882   0^83^B2036 8971
  27883   "RTN","VPR UPD",1,0)
  27884   VPRUPD ;SL C/MKB - Up date local  data ;11/ 13/13 2:11 pm
  27885   "RTN","VPR UPD",2,0)
  27886    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  27887   "RTN","VPR UPD",3,0)
  27888    ;
  27889   "RTN","VPR UPD",4,0)
  27890   PHONE(VPR, JSON) ; RP C = VPR PU T PHONE
  27891   "RTN","VPR UPD",5,0)
  27892    Q
  27893   "RTN","VPR UPD",6,0)
  27894   PUT(VPR,DF N,CMD,JSON ) ; -- upd ate phone  numbers
  27895   "RTN","VPR UPD",7,0)
  27896    ; RPC = V PR PUT DEM OGRAPHICS
  27897   "RTN","VPR UPD",8,0)
  27898    ;
  27899   "RTN","VPR UPD",9,0)
  27900    N ARRAY,V PRERR,ERR, HOME,CELL, NOK,ECON,X ,OK,VPRSYS
  27901   "RTN","VPR UPD",10,0)
  27902    S VPRSYS= $$GET^XPAR ("SYS","VP R SYSTEM N AME")
  27903   "RTN","VPR UPD",11,0)
  27904    D DECODE^ VPRJSON("J SON","ARRA Y","VPRERR ")
  27905   "RTN","VPR UPD",12,0)
  27906    I $D(VPRE RR) D  G P Q
  27907   "RTN","VPR UPD",13,0)
  27908    . K ARRAY  N VPRTMP, VPRTXT
  27909   "RTN","VPR UPD",14,0)
  27910    . S VPRTX T(1)="Prob lem decodi ng json in put."
  27911   "RTN","VPR UPD",15,0)
  27912    . D SETER ROR^VPRUTI LS(.VPRTMP ,.VPRERR,. VPRTXT,.JS ON)
  27913   "RTN","VPR UPD",16,0)
  27914    . K VPRER R D ENCODE ^VPRJSON(" VPRTMP","A RRAY","VPR ERR")
  27915   "RTN","VPR UPD",17,0)
  27916    . S VPR(. 5)="{""api Version"": ""1.01""," "error"":{ "
  27917   "RTN","VPR UPD",18,0)
  27918    . M VPR(1 )=ARRAY
  27919   "RTN","VPR UPD",19,0)
  27920    . S VPR(2 )="}}"
  27921   "RTN","VPR UPD",20,0)
  27922    ;
  27923   "RTN","VPR UPD",21,0)
  27924    S DFN=+$G (DFN) I DF N<1 S ERR= $$ERR(1,DF N) G PHQ
  27925   "RTN","VPR UPD",22,0)
  27926    S CMD=$G( CMD) ;can  only updat e phone#
  27927   "RTN","VPR UPD",23,0)
  27928    N VPRX,VP RDR,I,J S  (VPRDR,HOM E,CELL,NOK ,ECON)=""
  27929   "RTN","VPR UPD",24,0)
  27930    D VAL("ol d")
  27931   "RTN","VPR UPD",25,0)
  27932    S I="" F   S I=$O(AR RAY("telec oms",I)) Q :I<1  D
  27933   "RTN","VPR UPD",26,0)
  27934    . I $G(AR RAY("telec oms",I,"us ageCode")) ="H" D  Q
  27935   "RTN","VPR UPD",27,0)
  27936    .. S HOME =$G(ARRAY( "telecoms" ,I,"teleco m"))
  27937   "RTN","VPR UPD",28,0)
  27938    .. I HOME =HOME("old ") S HOME= "" Q            ;no c hange
  27939   "RTN","VPR UPD",29,0)
  27940    .. I "@"[ HOME S:$L( HOME("old" )) HOME="@ " Q  ;dele te
  27941   "RTN","VPR UPD",30,0)
  27942    .. S HOME =$$FORMAT( HOME),ARRA Y("telecom s",I,"tele com")=HOME
  27943   "RTN","VPR UPD",31,0)
  27944    . I $G(AR RAY("telec oms",I,"us ageCode")) ="MC" D  Q
  27945   "RTN","VPR UPD",32,0)
  27946    .. S CELL =$G(ARRAY( "telecoms" ,I,"teleco m"))
  27947   "RTN","VPR UPD",33,0)
  27948    .. I CELL =CELL("old ") S CELL= "" Q            ;no c hange
  27949   "RTN","VPR UPD",34,0)
  27950    .. I "@"[ CELL S:$L( CELL("old" )) CELL="@ " Q  ;dele te
  27951   "RTN","VPR UPD",35,0)
  27952    .. S CELL =$$FORMAT( CELL),ARRA Y("telecom s",I,"tele com")=CELL
  27953   "RTN","VPR UPD",36,0)
  27954    S I="" F   S I=$O(AR RAY("suppo rts",I)) Q :I<1  D
  27955   "RTN","VPR UPD",37,0)
  27956    . S X=$P( $G(ARRAY(" supports", I,"contact TypeCode") ),":",4) Q :X=""  ;NO K or ECON
  27957   "RTN","VPR UPD",38,0)
  27958    . S J=""  F  S J=$O( ARRAY("sup ports",I," telecomLis t",J)) Q:J <1  D
  27959   "RTN","VPR UPD",39,0)
  27960    .. Q:$G(A RRAY("supp orts",I,"t elecomList ",J,"usage Code"))'=" H"
  27961   "RTN","VPR UPD",40,0)
  27962    .. S @X=$ G(ARRAY("s upports",I ,"telecomL ist",J,"te lecom"))
  27963   "RTN","VPR UPD",41,0)
  27964    .. I @X=@ X@("old")  S @X="" Q                  ;no c hange
  27965   "RTN","VPR UPD",42,0)
  27966    .. I "@"[ @X S:$L(@X @("old"))  @X="@" Q        ;dele te
  27967   "RTN","VPR UPD",43,0)
  27968    .. S @X=$ $FORMAT(@X ),ARRAY("s upports",I ,"telecomL ist",J,"te lecom")=@X
  27969   "RTN","VPR UPD",44,0)
  27970    .. ; X="N OK" S NOK= $$FORMAT(N OK),ARRAY( "supports" ,I,"teleco mList",J," telecom")= NOK
  27971   "RTN","VPR UPD",45,0)
  27972    ;
  27973   "RTN","VPR UPD",46,0)
  27974    S:$L(HOME ) VPRX(.13 1)=HOME,VP RDR=".131"
  27975   "RTN","VPR UPD",47,0)
  27976    S:$L(CELL ) VPRX(.13 4)=CELL,VP RDR=VPRDR_ $S($L(VPRD R):";",1:" ")_".134"
  27977   "RTN","VPR UPD",48,0)
  27978    S:$L(ECON ) VPRX(.33 9)=ECON,VP RDR=VPRDR_ $S($L(VPRD R):";",1:" ")_".339"
  27979   "RTN","VPR UPD",49,0)
  27980    S:$L(NOK)  VPRX(.219 )=NOK,VPRD R=VPRDR_$S ($L(VPRDR) :";",1:"") _".219"
  27981   "RTN","VPR UPD",50,0)
  27982    I '$O(VPR X(0)) S ER R=$$ERR(3)  G PHQ
  27983   "RTN","VPR UPD",51,0)
  27984    D EDIT^VA FCPTED(DFN ,"VPRX",VP RDR)
  27985   "RTN","VPR UPD",52,0)
  27986    S X=$G(^D PT(DFN,.13 )),OK=1 D   ;check gl obal
  27987   "RTN","VPR UPD",53,0)
  27988    . I $L(HO ME),$S(HOM E="@":$L($ P(X,U)),1: (VPRX(.131 )'=$P(X,U) )) S OK=0
  27989   "RTN","VPR UPD",54,0)
  27990    . I $L(CE LL),$S(CEL L="@":$L($ P(X,U,4)), 1:(VPRX(.1 34)'=$P(X, U,4))) S O K=0
  27991   "RTN","VPR UPD",55,0)
  27992    . I $L(EC ON) S X=$G (^DPT(DFN, .33)) I $S (ECON="@": $L($P(X,U, 9)),1:(VPR X(.339)'=$ P(X,U,9)))  S OK=0
  27993   "RTN","VPR UPD",56,0)
  27994    . I $L(NO K) S X=$G( ^DPT(DFN,. 21)) I $S( NOK="@":$L ($P(X,U,9) ),1:(VPRX( .219)'=$P( X,U,9))) S  OK=0
  27995   "RTN","VPR UPD",57,0)
  27996    S:'OK ERR =$$ERR(5)
  27997   "RTN","VPR UPD",58,0)
  27998    ;
  27999   "RTN","VPR UPD",59,0)
  28000   PHQ ; add  item count  and termi nating cha racters
  28001   "RTN","VPR UPD",60,0)
  28002    I $D(ERR)  S VPR(1)= "{""apiVer sion"":""1 .01"",""er ror"":{""m essage"":" ""_ERR_""" },""succes s"":false} " G PQ
  28003   "RTN","VPR UPD",61,0)
  28004    ; VPR="{" "apiVersio n"":""1.01 "",""data" ":{""updat ed"":"_""" "_$$HL7NOW _""""_","" localId"": """_DFN_"" "},""succe ss"":true} "
  28005   "RTN","VPR UPD",62,0)
  28006    D POSTX^V PREVNT("pa tient",DFN )
  28007   "RTN","VPR UPD",63,0)
  28008    D ENCODE^ VPRJSON("A RRAY","VPR ","VPRERR" )
  28009   "RTN","VPR UPD",64,0)
  28010    I $D(VPRE RR) D  G P Q
  28011   "RTN","VPR UPD",65,0)
  28012    . K VPR N  VPRTMP,VP RTXT
  28013   "RTN","VPR UPD",66,0)
  28014    . S VPRTX T(1)="Prob lem encodi ng json ou tput."
  28015   "RTN","VPR UPD",67,0)
  28016    . D SETER ROR^VPRUTI LS(.VPRTMP ,.VPRERR,. VPRTXT,.AR RAY)
  28017   "RTN","VPR UPD",68,0)
  28018    . K VPRER R D ENCODE ^VPRJSON(" VPRTMP","V PR","VPRER R")
  28019   "RTN","VPR UPD",69,0)
  28020    . S VPR(. 5)="{""api Version"": ""1.01""," "error"":{ ",VPR(99)= "}}"
  28021   "RTN","VPR UPD",70,0)
  28022    S VPR(.5) ="{""apiVe rsion"":"" 1.01"",""p arams"":{" _$$SYS^VPR DJ_"},""su ccess"":tr ue,"
  28023   "RTN","VPR UPD",71,0)
  28024    S VPR(.6) ="""data"" :{""update d"":"""_$$ HL7NOW^VPR DJ_""",""t otalItems" ":1,""item s"":["
  28025   "RTN","VPR UPD",72,0)
  28026    S VPR(99) ="]}}"
  28027   "RTN","VPR UPD",73,0)
  28028   PQ ; exit
  28029   "RTN","VPR UPD",74,0)
  28030    K ^TMP($J ,"VPR")
  28031   "RTN","VPR UPD",75,0)
  28032    M ^TMP($J ,"VPR")=VP R
  28033   "RTN","VPR UPD",76,0)
  28034    K VPR S V PR=$NA(^TM P($J,"VPR" ))
  28035   "RTN","VPR UPD",77,0)
  28036    Q
  28037   "RTN","VPR UPD",78,0)
  28038    ;
  28039   "RTN","VPR UPD",79,0)
  28040   FORMAT(X)  ; -- enfor ce (xxx)xx x-xxxx pho ne format
  28041   "RTN","VPR UPD",80,0)
  28042    S X=$G(X)  I X?1"("3 N1")"3N1"- "4N.E Q X
  28043   "RTN","VPR UPD",81,0)
  28044    N P,N,I,Y  S P=""
  28045   "RTN","VPR UPD",82,0)
  28046    F I=1:1:$ L(X) S N=$ E(X,I) I N =+N S P=P_ N
  28047   "RTN","VPR UPD",83,0)
  28048    S:$L(P)<1 0 P=$E("00 00000000", 1,10-$L(P) )_P
  28049   "RTN","VPR UPD",84,0)
  28050    S Y=$S(P: "("_$E(P,1 ,3)_")"_$E (P,4,6)_"- "_$E(P,7,1 0),1:"")
  28051   "RTN","VPR UPD",85,0)
  28052    Q Y
  28053   "RTN","VPR UPD",86,0)
  28054    ;
  28055   "RTN","VPR UPD",87,0)
  28056   HL7NOW() ;  -- Return  current t ime in HL7  format
  28057   "RTN","VPR UPD",88,0)
  28058    Q $P($$FM THL7^XLFDT ($$NOW^XLF DT),"-")
  28059   "RTN","VPR UPD",89,0)
  28060    ;
  28061   "RTN","VPR UPD",90,0)
  28062   ERR(X,VAL)  ; -- retu rn error m essage
  28063   "RTN","VPR UPD",91,0)
  28064    N MSG  S  MSG="Error "
  28065   "RTN","VPR UPD",92,0)
  28066    I X=1  S  MSG="Patie nt with df n '"_$G(VA L)_"' not  found"
  28067   "RTN","VPR UPD",93,0)
  28068    I X=2  S  MSG="Domai n type '"_ $G(VAL)_"'  not recog nized"
  28069   "RTN","VPR UPD",94,0)
  28070    I X=3  S  MSG="Data  not change d"
  28071   "RTN","VPR UPD",95,0)
  28072    I X=4  S  MSG="Unabl e to creat e new obje ct"
  28073   "RTN","VPR UPD",96,0)
  28074    I X=5  S  MSG="Updat e failed"
  28075   "RTN","VPR UPD",97,0)
  28076    I X=99 S  MSG="Unkno wn request "
  28077   "RTN","VPR UPD",98,0)
  28078    Q MSG
  28079   "RTN","VPR UPD",99,0)
  28080    ;
  28081   "RTN","VPR UPD",100,0 )
  28082   VAL(SUB) ;  -- pull v alues from  ^DPT
  28083   "RTN","VPR UPD",101,0 )
  28084    N X S X=$ G(^DPT(DFN ,.13))
  28085   "RTN","VPR UPD",102,0 )
  28086    S HOME(SU B)=$P(X,U) ,CELL(SUB) =$P(X,U,4)
  28087   "RTN","VPR UPD",103,0 )
  28088    S X=$G(^D PT(DFN,.33 )),ECON(SU B)=$P(X,U, 9)
  28089   "RTN","VPR UPD",104,0 )
  28090    S X=$G(^D PT(DFN,.21 )),NOK(SUB )=$P(X,U,9 )
  28091   "RTN","VPR UPD",105,0 )
  28092    Q
  28093   "RTN","VPR UTILS")
  28094   0^93^B1865 9956
  28095   "RTN","VPR UTILS",1,0 )
  28096   VPRUTILS ; SLC/AGP --  VPR utili ties routi ne ;8/14/1 3  11:22
  28097   "RTN","VPR UTILS",2,0 )
  28098    ;;1.0;VIR TUAL PATIE NT RECORD; **2,3**;Se p 01, 2011 ;Build 283
  28099   "RTN","VPR UTILS",3,0 )
  28100    ;
  28101   "RTN","VPR UTILS",4,0 )
  28102    ; Externa l Referenc es           DBIA#
  28103   "RTN","VPR UTILS",5,0 )
  28104    ; ------- ---------- --           -----
  28105   "RTN","VPR UTILS",6,0 )
  28106    ; XLFCRC                           3156
  28107   "RTN","VPR UTILS",7,0 )
  28108    ; XLFDT                           10103
  28109   "RTN","VPR UTILS",8,0 )
  28110    ; XLFUTL                           2622
  28111   "RTN","VPR UTILS",9,0 )
  28112    ; XUPARAM                          2541
  28113   "RTN","VPR UTILS",10, 0)
  28114    ;
  28115   "RTN","VPR UTILS",11, 0)
  28116    Q
  28117   "RTN","VPR UTILS",12, 0)
  28118    ;
  28119   "RTN","VPR UTILS",13, 0)
  28120   SETERROR(R ESULT,ERRO R,EXTERROR ,DATA) ; - - error te xt for JSO N
  28121   "RTN","VPR UTILS",14, 0)
  28122    N CNT,TEM P,VPRTEMP, XCNT
  28123   "RTN","VPR UTILS",15, 0)
  28124    S VPRTEMP ="VPRXTEMP  ERRORS"
  28125   "RTN","VPR UTILS",16, 0)
  28126    I '$D(^XT MP(VPRTEMP ,0)) S ^XT MP(VPRTEMP ,0)=$$FMAD D^XLFDT(DT ,7)_U_DT_U _"VPR ERRO R GLOBAL"
  28127   "RTN","VPR UTILS",17, 0)
  28128    S RESULT( "success") ="false"
  28129   "RTN","VPR UTILS",18, 0)
  28130    I $D(DATA ) S XCNT=$ O(^XTMP(VP RTEMP,""), -1)+1 M ^X TMP(VPRTEM P,XCNT,"ER ROR")=DATA
  28131   "RTN","VPR UTILS",19, 0)
  28132    I $D(ERRO R) D SETER RTX(.TEMP, .ERROR) S  RESULT("er ror","code ")=TEMP
  28133   "RTN","VPR UTILS",20, 0)
  28134    I +$G(XCN T)>0 S RES ULT("error ","code")= $G(RESULT( "error","c ode"))_" S ee ^XTMP(" _VPRTEMP_" ,"_XCNT_", DATA) for  data"
  28135   "RTN","VPR UTILS",21, 0)
  28136    I $D(EXTE RROR) D SE TERRTX(.TE MP,.EXTERR OR) I TEMP '="" S RES ULT("error ","message ")=TEMP
  28137   "RTN","VPR UTILS",22, 0)
  28138    ;
  28139   "RTN","VPR UTILS",23, 0)
  28140    Q
  28141   "RTN","VPR UTILS",24, 0)
  28142    ;
  28143   "RTN","VPR UTILS",25, 0)
  28144   SETERRTX(T EMP,ERROR)  ;
  28145   "RTN","VPR UTILS",26, 0)
  28146    S TEMP=""
  28147   "RTN","VPR UTILS",27, 0)
  28148    S CNT=0 F   S CNT=$O (ERROR(CNT )) Q:CNT'> 0  D
  28149   "RTN","VPR UTILS",28, 0)
  28150    .S TEMP=$ S(TEMP'="" :TEMP=TEMP _$C(13,10) _ERROR(CNT ),1:ERROR( CNT))
  28151   "RTN","VPR UTILS",29, 0)
  28152    Q
  28153   "RTN","VPR UTILS",30, 0)
  28154    ;
  28155   "RTN","VPR UTILS",31, 0)
  28156   SETTEXT(X, VALUE) ; - - format w ord proces sing
  28157   "RTN","VPR UTILS",32, 0)
  28158    N FIRST,I ,LINE
  28159   "RTN","VPR UTILS",33, 0)
  28160    S FIRST=1
  28161   "RTN","VPR UTILS",34, 0)
  28162    S I=0 F   S I=$O(@X@ (I)) Q:I<1   D
  28163   "RTN","VPR UTILS",35, 0)
  28164    .S LINE=$ S($D(@X@(I ,0)):@X@(I ,0),1:@X@( I))
  28165   "RTN","VPR UTILS",36, 0)
  28166    .; FIRST= 1 S @VALUE @(I)=LINE, FIRST=0 Q
  28167   "RTN","VPR UTILS",37, 0)
  28168    .S @VALUE @(I)=LINE_ $C(13)_$C( 10)
  28169   "RTN","VPR UTILS",38, 0)
  28170    Q
  28171   "RTN","VPR UTILS",39, 0)
  28172    ;
  28173   "RTN","VPR UTILS",40, 0)
  28174   SPLITVAL(N ODE,ARRAY)  ; -- spli t a value  into a lis t
  28175   "RTN","VPR UTILS",41, 0)
  28176    N CNT,NAM E,VALUE,FI ELD
  28177   "RTN","VPR UTILS",42, 0)
  28178    S NAME=""  F  S NAME =$O(ARRAY( NAME)) Q:N AME=""  D
  28179   "RTN","VPR UTILS",43, 0)
  28180    .S CNT=+A RRAY(NAME)
  28181   "RTN","VPR UTILS",44, 0)
  28182    .S VALUE= $P($G(NODE ),U,CNT)
  28183   "RTN","VPR UTILS",45, 0)
  28184    .I NAME=" Code" S FI ELD=$P(ARR AY(NAME),U ,2) S VALU E=$$SETVUR N(FIELD,VA LUE)
  28185   "RTN","VPR UTILS",46, 0)
  28186    .S ARRAY( NAME)=VALU E
  28187   "RTN","VPR UTILS",47, 0)
  28188    Q
  28189   "RTN","VPR UTILS",48, 0)
  28190    ;
  28191   "RTN","VPR UTILS",49, 0)
  28192   SETPROV(NO DE,PROV) ;  -- provid ers
  28193   "RTN","VPR UTILS",50, 0)
  28194    S PROV("p roviderUid ")=$$SETUI D("user",, +NODE)
  28195   "RTN","VPR UTILS",51, 0)
  28196    S PROV("p roviderNam e")=$P(NOD E,U,2)
  28197   "RTN","VPR UTILS",52, 0)
  28198    Q
  28199   "RTN","VPR UTILS",53, 0)
  28200    ;
  28201   "RTN","VPR UTILS",54, 0)
  28202   SETUID(DOM AIN,PAT,ID ,ADDDATA)  ; -- creat e uid stri ng
  28203   "RTN","VPR UTILS",55, 0)
  28204    N RESULT, SYS
  28205   "RTN","VPR UTILS",56, 0)
  28206    S SYS=$S( $D(VPRSYS) :VPRSYS,1: $$GET^XPAR ("SYS","VP R SYSTEM N AME"))
  28207   "RTN","VPR UTILS",57, 0)
  28208    S RESULT= "urn:va:"_ DOMAIN_":" _SYS_":"_$ S($G(PAT): PAT_":",1: "")_ID
  28209   "RTN","VPR UTILS",58, 0)
  28210    I $L($G(A DDDATA)) S  RESULT=RE SULT_":"_A DDDATA
  28211   "RTN","VPR UTILS",59, 0)
  28212    Q RESULT
  28213   "RTN","VPR UTILS",60, 0)
  28214    ;
  28215   "RTN","VPR UTILS",61, 0)
  28216   SETFCURN(D OMAIN,FACI LITY,VALUE ) ; -- cre ate facili ty urn
  28217   "RTN","VPR UTILS",62, 0)
  28218    Q "urn:va :"_DOMAIN_ ":"_FACILI TY_":"_VAL UE
  28219   "RTN","VPR UTILS",63, 0)
  28220    ;
  28221   "RTN","VPR UTILS",64, 0)
  28222   SETVURN(DO MAIN,VALUE ) ; -- cre ate VA urn
  28223   "RTN","VPR UTILS",65, 0)
  28224    N RESULT  S RESULT=" "
  28225   "RTN","VPR UTILS",66, 0)
  28226    S RESULT= "urn:va:"_ DOMAIN_":" _VALUE
  28227   "RTN","VPR UTILS",67, 0)
  28228    Q RESULT
  28229   "RTN","VPR UTILS",68, 0)
  28230    ;
  28231   "RTN","VPR UTILS",69, 0)
  28232   SYS() ; --  return ha shed syste m name
  28233   "RTN","VPR UTILS",70, 0)
  28234    Q $$BASE^ XLFUTL($$C RC16^XLFCR C($$KSP^XU PARAM("WHE RE")),10,1 6)
  28235   "RTN","VPR UTILS",71, 0)
  28236    ;
  28237   "RTN","VPR UTILS",72, 0)
  28238   SETNCS(COD ESET,VALUE ) ; -- cre ate nation al codeset  urn
  28239   "RTN","VPR UTILS",73, 0)
  28240    Q "urn:"_ CODESET_": "_VALUE
  28241   "RTN","VPR UTILS",74, 0)
  28242    ;
  28243   "RTN","VPR UTILS",75, 0)
  28244   JSONDT(X)  ; -- conve rt FileMan  DT to HL7  DT for JS ON
  28245   "RTN","VPR UTILS",76, 0)
  28246    N D,DATE, M,TIME,Y
  28247   "RTN","VPR UTILS",77, 0)
  28248    S DATE=$P ($$FMTHL7^ XLFDT(X)," -")
  28249   "RTN","VPR UTILS",78, 0)
  28250    I $L(DATE )>8 S TIME =$E(DATE,9 ,$L(DATE))
  28251   "RTN","VPR UTILS",79, 0)
  28252    S Y=$E(DA TE,1,4),M= $E(DATE,5, 6),D=$E(DA TE,7,8)
  28253   "RTN","VPR UTILS",80, 0)
  28254    K DATE
  28255   "RTN","VPR UTILS",81, 0)
  28256    S DATE=Y  I M>0 S DA TE=DATE_M  S:D>0 DATE =DATE_D
  28257   "RTN","VPR UTILS",82, 0)
  28258    I $G(TIME )'="" D  S  DATE=DATE _TIME
  28259   "RTN","VPR UTILS",83, 0)
  28260    . N S S S =$E(TIME_" 000000",5, 6)
  28261   "RTN","VPR UTILS",84, 0)
  28262    . I S,S>5 9 S TIME=$ E(TIME,1,4 ) ;strip b ad seconds
  28263   "RTN","VPR UTILS",85, 0)
  28264    Q DATE
  28265   "RTN","VPR UTILS",86, 0)
  28266    ;
  28267   "RTN","VPR UTILS",87, 0)
  28268   FACILITY(X ,Y) ; -- a dd facilit y info to  array for  JSON
  28269   "RTN","VPR UTILS",88, 0)
  28270    ;  X=STAT ION NUMBER ^STATION N AME
  28271   "RTN","VPR UTILS",89, 0)
  28272    ;  Y=Vari able array  name
  28273   "RTN","VPR UTILS",90, 0)
  28274    ; >D FACI LITY^VPRUT ILS("500^C AMP MASTER ","LAB")
  28275   "RTN","VPR UTILS",91, 0)
  28276    ;
  28277   "RTN","VPR UTILS",92, 0)
  28278    S @Y@("fa cilityCode ")=$P(X,"^ ")
  28279   "RTN","VPR UTILS",93, 0)
  28280    S @Y@("fa cilityName ")=$P(X,"^ ",2)
  28281   "RTN","VPR UTILS",94, 0)
  28282    Q
  28283   "RTN","VPR UTILS",95, 0)
  28284   VERSRV()    ; Return  server ver sion of op tion name
  28285   "RTN","VPR UTILS",96, 0)
  28286    N VPRLST, VAL
  28287   "RTN","VPR UTILS",97, 0)
  28288    D FIND^DI C(19,"",1, "X","VPR U I CONTEXT" ,1,,,,"VPR LST")
  28289   "RTN","VPR UTILS",98, 0)
  28290    S VAL=$G( VPRLST("DI LIST","ID" ,1,1))
  28291   "RTN","VPR UTILS",99, 0)
  28292    Q $$UP^XL FSTR($P(VA L,"version  ",2))
  28293   "RTN","VPR UTILS",100 ,0)
  28294    ;
  28295   "RTN","VPR UTILS",101 ,0)
  28296   VERCMP(CUR ,VAL) ; Re turns 1 if  CUR<VAL,  -1 if CUR> VAL, 0 if  equal
  28297   "RTN","VPR UTILS",102 ,0)
  28298    N CURMAJO R,CURMINOR ,CURSNAP,V ALMAJOR,VA LMINOR,VAL SNAP
  28299   "RTN","VPR UTILS",103 ,0)
  28300    S CURMAJO R=$P(CUR," -"),CURMIN OR=$P(CUR, "-",2),CUR SNAP=$E($P (CUR,"-",3 ),1,4)="SN AP"
  28301   "RTN","VPR UTILS",104 ,0)
  28302    S VALMAJO R=$P(VAL," -"),VALMIN OR=$P(VAL, "-",2),VAL SNAP=$E($P (VAL,"-",3 ),1,4)="SN AP"
  28303   "RTN","VPR UTILS",105 ,0)
  28304    I $E(VALM INOR)="P"  S VALMINOR =$E(VALMIN OR,2,99)      ; "P"il ot version s (old)
  28305   "RTN","VPR UTILS",106 ,0)
  28306    I $E(CURM INOR)="P"  S CURMINOR =$E(VALMIN OR,2,99)
  28307   "RTN","VPR UTILS",107 ,0)
  28308    I $E(VALM INOR)="S"  S VALMINOR =$E(VALMIN OR,2,99)*1 0  ; "S"pr int versio ns
  28309   "RTN","VPR UTILS",108 ,0)
  28310    I $E(CURM INOR)="S"  S CURMINOR =$E(CURMIN OR,2,99)*1 0
  28311   "RTN","VPR UTILS",109 ,0)
  28312    Q:VALMAJO R>CURMAJOR  1   Q:VAL MAJOR<CURM AJOR -1  ;  compare m ajor versi ons
  28313   "RTN","VPR UTILS",110 ,0)
  28314    Q:VALMINO R>CURMINOR  1   Q:VAL MINOR<CURM INOR -1  ;  compare m inor versi ons
  28315   "RTN","VPR UTILS",111 ,0)
  28316    Q:(CURSNA P&'VALSNAP ) 1  Q:(VA LSNAP&'CUR SNAP) -1 ;  "SNAPSHOT " < releas ed
  28317   "RTN","VPR UTILS",112 ,0)
  28318    Q 0
  28319   "RTN","VPR UTILS",113 ,0)
  28320    ;
  28321   "RTN","VPR YCSI")
  28322   0^102^B163 64707
  28323   "RTN","VPR YCSI",1,0)
  28324   VPRYCSI ;S LC/KCM --  Convert sy stem ident ifier in U ID's for V PR objects
  28325   "RTN","VPR YCSI",2,0)
  28326    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  28327   "RTN","VPR YCSI",3,0)
  28328    ;
  28329   "RTN","VPR YCSI",4,0)
  28330   EN ; Promp t for if t he system  should rea lly conver t
  28331   "RTN","VPR YCSI",5,0)
  28332    N DIR,DTO UT,DUOUT,D IRUT,DIROU T,X,Y,DA,F ROMSYS,TOS YS
  28333   "RTN","VPR YCSI",6,0)
  28334    S DIR(0)= "F:4:40",D IR("A")="C onvert fro m (System  ID or Doma in Name)"
  28335   "RTN","VPR YCSI",7,0)
  28336    S DIR("?" )="Enter t he four ch aracter sy stem ID or  the domai n name."
  28337   "RTN","VPR YCSI",8,0)
  28338    D ^DIR Q: $D(DIRUT)
  28339   "RTN","VPR YCSI",9,0)
  28340    S Y=$$UP^ XLFSTR(Y), TOSYS=$$SY S^VPRUTILS
  28341   "RTN","VPR YCSI",10,0 )
  28342    I $L(Y)'= 4,Y["." S  Y=$$CNV^XL FUTL($$CRC 16^XLFCRC( Y),16)
  28343   "RTN","VPR YCSI",11,0 )
  28344    I Y=TOSYS  W !,"Same  ID as thi s system."  Q
  28345   "RTN","VPR YCSI",12,0 )
  28346    W !,"This  will (bru te force)  replace al l instance s of "":"_ Y_":"""
  28347   "RTN","VPR YCSI",13,0 )
  28348    W !,"                                  wit h instance s of "":"_ TOSYS_":"" "
  28349   "RTN","VPR YCSI",14,0 )
  28350    W !,"Cont inue? NO// " R X:300  Q:$E($$UP^ XLFSTR(X)) '="Y"
  28351   "RTN","VPR YCSI",15,0 )
  28352    ;
  28353   "RTN","VPR YCSI",16,0 )
  28354    N FROMSYS
  28355   "RTN","VPR YCSI",17,0 )
  28356    S FROMSYS =Y
  28357   "RTN","VPR YCSI",18,0 )
  28358    W !,"File  560.1:  "
  28359   "RTN","VPR YCSI",19,0 )
  28360    D CONV(FR OMSYS,560. 1)
  28361   "RTN","VPR YCSI",20,0 )
  28362    W !,"File  560.11: "
  28363   "RTN","VPR YCSI",21,0 )
  28364    D CONV(FR OMSYS,560. 11)
  28365   "RTN","VPR YCSI",22,0 )
  28366    Q
  28367   "RTN","VPR YCSI",23,0 )
  28368   CONV(FROMS YS,FILENUM ) ; FROMSY S is the s ystem id t o be conve rted
  28369   "RTN","VPR YCSI",24,0 )
  28370    N TOSYS,F DAIEN
  28371   "RTN","VPR YCSI",25,0 )
  28372    S TOSYS=$ $SYS^VPRUT ILS
  28373   "RTN","VPR YCSI",26,0 )
  28374    S FDAIEN= 0 F  S FDA IEN=$O(^VP R(FILENUM, FDAIEN)) Q :'FDAIEN   D CONV1(FI LENUM,FDAI EN,FROMSYS ,TOSYS)
  28375   "RTN","VPR YCSI",27,0 )
  28376    Q
  28377   "RTN","VPR YCSI",28,0 )
  28378   CONV1(FILE NUM,FDAIEN ,FROMSYS,T OSYS) ; co nvert one  record
  28379   "RTN","VPR YCSI",29,0 )
  28380    ; system  id is assu med to be  the fourth  piece
  28381   "RTN","VPR YCSI",30,0 )
  28382    N X0,UID, SYS,WPORIG ,WPNEW,VAL
  28383   "RTN","VPR YCSI",31,0 )
  28384    S X0=$G(^ VPR(FILENU M,FDAIEN,0 )),UID=$P( X0,"^",1), SYS=$P(UID ,":",4)
  28385   "RTN","VPR YCSI",32,0 )
  28386    Q:SYS=TOS YS  ; alre ady native  to this a ccount
  28387   "RTN","VPR YCSI",33,0 )
  28388    S $P(UID, ":",4)=TOS YS
  28389   "RTN","VPR YCSI",34,0 )
  28390    M WPORIG= ^VPR(FILEN UM,FDAIEN, 1)
  28391   "RTN","VPR YCSI",35,0 )
  28392    S VAL=$$W P2X(.WPORI G)
  28393   "RTN","VPR YCSI",36,0 )
  28394    S VAL=$$S WAP(VAL,": "_FROMSYS_ ":",":"_TO SYS_":")
  28395   "RTN","VPR YCSI",37,0 )
  28396    D X2WP(VA L,.WPNEW)
  28397   "RTN","VPR YCSI",38,0 )
  28398    D SAVE(FI LENUM,FDAI EN,UID,.WP NEW)
  28399   "RTN","VPR YCSI",39,0 )
  28400    W "."
  28401   "RTN","VPR YCSI",40,0 )
  28402    Q
  28403   "RTN","VPR YCSI",41,0 )
  28404   SWAP(X,FIN D,REPLACE)  ; swap st ring FIND  with strin g REPLACE  in X
  28405   "RTN","VPR YCSI",42,0 )
  28406    N Y,POS,S IZE
  28407   "RTN","VPR YCSI",43,0 )
  28408    S Y="",PO S=0,SIZE=$ L(FIND)
  28409   "RTN","VPR YCSI",44,0 )
  28410    F  S POS= $F(X,FIND, POS) Q:'PO S  S $E(X, POS-SIZE,P OS-1)=REPL ACE
  28411   "RTN","VPR YCSI",45,0 )
  28412    Q X
  28413   "RTN","VPR YCSI",46,0 )
  28414    ;
  28415   "RTN","VPR YCSI",47,0 )
  28416   WP2X(WP) ;  Return a  single str ing by con catenating  the WP fi elds
  28417   "RTN","VPR YCSI",48,0 )
  28418    N I,X,ERR
  28419   "RTN","VPR YCSI",49,0 )
  28420    S X="",ER R=0
  28421   "RTN","VPR YCSI",50,0 )
  28422    S I=0 F   S I=$O(WP( I)) Q:'I   D  Q:ERR
  28423   "RTN","VPR YCSI",51,0 )
  28424    . I ($L(X )+$L(WP(I, 0)))>32000  D  Q
  28425   "RTN","VPR YCSI",52,0 )
  28426    . . S ERR =1,X=""
  28427   "RTN","VPR YCSI",53,0 )
  28428    . . W !," Can't conv ert docume nts longer  than 32K" ,!
  28429   "RTN","VPR YCSI",54,0 )
  28430    . S X=X_W P(I,0)
  28431   "RTN","VPR YCSI",55,0 )
  28432    Q X
  28433   "RTN","VPR YCSI",56,0 )
  28434   X2WP(X,WP, SIZE) ; Co nvert a st ring to WP  field wit h strings  no longer  than SIZE
  28435   "RTN","VPR YCSI",57,0 )
  28436    N START,S TOP,LINE,I DX
  28437   "RTN","VPR YCSI",58,0 )
  28438    S SIZE=$G (SIZE,245) -1 Q:'SIZE
  28439   "RTN","VPR YCSI",59,0 )
  28440    S START=1 ,IDX=0
  28441   "RTN","VPR YCSI",60,0 )
  28442    F  Q:STAR T>$L(X)  D
  28443   "RTN","VPR YCSI",61,0 )
  28444    . S STOP= START+SIZE ,LINE=$E(X ,START,STO P),START=S TOP+1
  28445   "RTN","VPR YCSI",62,0 )
  28446    . I $L(LI NE) S IDX= IDX+1,WP(I DX,0)=LINE
  28447   "RTN","VPR YCSI",63,0 )
  28448    Q
  28449   "RTN","VPR YCSI",64,0 )
  28450   SAVE(FILEN UM,FDAIEN, UID,WP) ;
  28451   "RTN","VPR YCSI",65,0 )
  28452    N FDA,DIE RR,ERR
  28453   "RTN","VPR YCSI",66,0 )
  28454    S FDA(FIL ENUM,FDAIE N_",",.01) =UID
  28455   "RTN","VPR YCSI",67,0 )
  28456    D FILE^DI E("","FDA" ,"ERR")
  28457   "RTN","VPR YCSI",68,0 )
  28458    I $D(DIER R) W !,"Sa ve failed  for UID: " ,UID,! D W OUT("ERR")  Q
  28459   "RTN","VPR YCSI",69,0 )
  28460    I $D(WP)  D WP^DIE(F ILENUM,FDA IEN_",",1, "","WP","E RR")
  28461   "RTN","VPR YCSI",70,0 )
  28462    I $D(DIER R) W !,"Sa ve failed  for WP: ", UID,! D WO UT("ERR")  Q
  28463   "RTN","VPR YCSI",71,0 )
  28464    D CLEAN^D ILF
  28465   "RTN","VPR YCSI",72,0 )
  28466    Q
  28467   "RTN","VPR YCSI",73,0 )
  28468    ;
  28469   "RTN","VPR YCSI",74,0 )
  28470   CHECK(FILE NUM) ; Che ck JSON in tegrity of  FILENUM
  28471   "RTN","VPR YCSI",75,0 )
  28472    S IEN=0 F   S IEN=$O (^VPR(FILE NUM,IEN))  Q:'IEN  D  CHECK1(FIL ENUM,IEN)
  28473   "RTN","VPR YCSI",76,0 )
  28474    Q
  28475   "RTN","VPR YCSI",77,0 )
  28476   CHECK1(FIL ENUM,IEN)  ;
  28477   "RTN","VPR YCSI",78,0 )
  28478    N JSON,OB J,ERR,I
  28479   "RTN","VPR YCSI",79,0 )
  28480    S I=0 F   S I=$O(^VP R(FILENUM, IEN,1,I))  Q:'I  S JS ON(I)=^VPR (FILENUM,I EN,1,I,0)
  28481   "RTN","VPR YCSI",80,0 )
  28482    I $D(JSON )'>1 W !,F ILENUM,":" ,IEN,?20," no JSON pr esent" Q
  28483   "RTN","VPR YCSI",81,0 )
  28484    D DECODE^ VPRJSON("J SON","OBJ" ,"ERR")
  28485   "RTN","VPR YCSI",82,0 )
  28486    I $D(ERR)  W !,FILEN UM,":",IEN ,?20,$G(ER R(1))
  28487   "RTN","VPR YCSI",83,0 )
  28488    W "."
  28489   "RTN","VPR YCSI",84,0 )
  28490    Q
  28491   "RTN","VPR YCSI",85,0 )
  28492    ;
  28493   "RTN","VPR YCSI",86,0 )
  28494   TX2WP ;
  28495   "RTN","VPR YCSI",87,0 )
  28496    N INPUT,O UTPUT
  28497   "RTN","VPR YCSI",88,0 )
  28498    S INPUT=" abcdefghij klmnopqrst uvwxyz0123 456789abcd efghijklmn opqrstuvwx yz"
  28499   "RTN","VPR YCSI",89,0 )
  28500    D X2WP(IN PUT,.OUTPU T,5)  W !  D WOUT("OU TPUT") K O UTPUT
  28501   "RTN","VPR YCSI",90,0 )
  28502    D X2WP(IN PUT,.OUTPU T,10) W !  D WOUT("OU TPUT") K O UTPUT
  28503   "RTN","VPR YCSI",91,0 )
  28504    S INPUT=$ E(INPUT,1, 25)
  28505   "RTN","VPR YCSI",92,0 )
  28506    D X2WP(IN PUT,.OUTPU T,5)  W !  D WOUT("OU TPUT")
  28507   "RTN","VPR YCSI",93,0 )
  28508    Q
  28509   "RTN","VPR YCSI",94,0 )
  28510   TSWAP ;
  28511   "RTN","VPR YCSI",95,0 )
  28512    ;;{"uid": "urn:va:pe rsonphoto: F484:1123" ,"summary" :"gov.va.c pe.vpr.Per sonPhoto@2 66713c1"," personUid" :"urn:va:u ser:F484:1 123"}
  28513   "RTN","VPR YCSI",96,0 )
  28514    N X
  28515   "RTN","VPR YCSI",97,0 )
  28516    S X=$P($T (TSWAP+1), ";;",2,99)
  28517   "RTN","VPR YCSI",98,0 )
  28518    W !,X
  28519   "RTN","VPR YCSI",99,0 )
  28520    S X=$$SWA P(X,":F484 :",":0F0F: ")
  28521   "RTN","VPR YCSI",100, 0)
  28522    W !,X,!
  28523   "RTN","VPR YCSI",101, 0)
  28524    Q
  28525   "RTN","VPR YCSI",102, 0)
  28526   TSAVE ;
  28527   "RTN","VPR YCSI",103, 0)
  28528    S IEN=$O( ^VPR(560.1 1,"B","urn :va:person photo:2222 :123",0))  Q:'IEN
  28529   "RTN","VPR YCSI",104, 0)
  28530    W !,"IEN: ",IEN
  28531   "RTN","VPR YCSI",105, 0)
  28532    D CONV1(I EN,"2222", "3333")
  28533   "RTN","VPR YCSI",106, 0)
  28534    Q
  28535   "RTN","VPR YCSI",107, 0)
  28536    ;
  28537   "RTN","VPR YCSI",108, 0)
  28538   WOUT(ROOT)  ; Write o ut a varia ble named  by ROOT
  28539   "RTN","VPR YCSI",109, 0)
  28540    W !,ROOT, " -----"
  28541   "RTN","VPR YCSI",110, 0)
  28542    N X
  28543   "RTN","VPR YCSI",111, 0)
  28544    S X=ROOT  F  S X=$Q( @X) Q:'$L( X)  Q:$E(X ,1,$L(ROOT ))'=ROOT   W !,X,"=", @X
  28545   "RTN","VPR YCSI",112, 0)
  28546    Q
  28547   "RTN","VPR YFRP")
  28548   0^66^B9317 5404
  28549   "RTN","VPR YFRP",1,0)
  28550   VPRYFRP ;S LC/KCM --  Find recen t patients  and put o n roster
  28551   "RTN","VPR YFRP",2,0)
  28552    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  28553   "RTN","VPR YFRP",3,0)
  28554    ;
  28555   "RTN","VPR YFRP",4,0)
  28556   EN ; Utili ties for b uilding ro ster lists
  28557   "RTN","VPR YFRP",5,0)
  28558    W !,"D BL DMTHS to c reate list s"
  28559   "RTN","VPR YFRP",6,0)
  28560    W !,"D SH OWCNT to s ee how man y patients  in each m onth"
  28561   "RTN","VPR YFRP",7,0)
  28562    W !,"D XT RLST to ge t a single  month"
  28563   "RTN","VPR YFRP",8,0)
  28564    W !,"D GE T4ALL to d o extracts  for all t he patient s"
  28565   "RTN","VPR YFRP",9,0)
  28566    W !,"D SH OWSIZE to  show sizes  for each  month"
  28567   "RTN","VPR YFRP",10,0 )
  28568    W !,"D SH OWSTS to s how task s tatus and  any errors  in extrac ts"
  28569   "RTN","VPR YFRP",11,0 )
  28570    W !,"D SH OWTOP to s how the hi ghest time s and size s"
  28571   "RTN","VPR YFRP",12,0 )
  28572    W !,"D ST OP to stop  processin g of extra cts"
  28573   "RTN","VPR YFRP",13,0 )
  28574    W !!,"Dat a stored i n ^XTMP("" VPRYFRP"") ",!
  28575   "RTN","VPR YFRP",14,0 )
  28576    Q
  28577   "RTN","VPR YFRP",15,0 )
  28578    ;
  28579   "RTN","VPR YFRP",16,0 )
  28580   BLDMTHS ;  Build pati ent lists  for a rang e of month
  28581   "RTN","VPR YFRP",17,0 )
  28582    ; ^XTMP(" VPRYFRP"," FOUND",DFN )=""          ; patie nts alread y found
  28583   "RTN","VPR YFRP",18,0 )
  28584    ; ^XTMP(" VPRYFRP"," MONTH",YYY YMM,DFN)=" "  ; patie nts by mon th of last  visit
  28585   "RTN","VPR YFRP",19,0 )
  28586    ; MONTHS( inverseMon th)=YYYMM^ MmmYYYY       ; month s to measu re
  28587   "RTN","VPR YFRP",20,0 )
  28588    ;
  28589   "RTN","VPR YFRP",21,0 )
  28590    K ^XTMP(" VPRYFRP")
  28591   "RTN","VPR YFRP",22,0 )
  28592    S ^XTMP(" VPRYFRP",0 )=$$HTFM^X LFDT(+$H+4 )_"^"_$$HT FM^XLFDT(+ $H)_"^VPR  Build Rost ers by Mon th"
  28593   "RTN","VPR YFRP",23,0 )
  28594    ;
  28595   "RTN","VPR YFRP",24,0 )
  28596    N MTHBEG, MTHEND,MON TH,MONTHS
  28597   "RTN","VPR YFRP",25,0 )
  28598    D PRMTMTH S(.MTHBEG, .MTHEND) Q :'MTHBEG
  28599   "RTN","VPR YFRP",26,0 )
  28600    I MTHBEG> MTHEND N X  S X=MTHEN D,MTHEND=M THBEG,MTHB EG=X
  28601   "RTN","VPR YFRP",27,0 )
  28602    S MONTH=M THBEG F  D   Q:MONTH> MTHEND
  28603   "RTN","VPR YFRP",28,0 )
  28604    . S MONTH S(MONTH)=M ONTH_"^"_$ $EXTMTH(MO NTH)
  28605   "RTN","VPR YFRP",29,0 )
  28606    . S MONTH =$$INCMTH( MONTH)
  28607   "RTN","VPR YFRP",30,0 )
  28608    S MONTH=0  F  S MONT H=$O(MONTH S(MONTH))  Q:'MONTH   D BLDMTH(M ONTHS(MONT H)) W "."
  28609   "RTN","VPR YFRP",31,0 )
  28610    W ! D SHO WCNT
  28611   "RTN","VPR YFRP",32,0 )
  28612    Q
  28613   "RTN","VPR YFRP",33,0 )
  28614   BLDMTH(MON TH) ; Buil d list of  patients f or a month
  28615   "RTN","VPR YFRP",34,0 )
  28616    N NAME,ST ART,STOP,V DATE,VISIT ,X0,DFN,CA T
  28617   "RTN","VPR YFRP",35,0 )
  28618    S START=$ P(MONTH,"^ "),NAME=$P (MONTH,"^" ,2)
  28619   "RTN","VPR YFRP",36,0 )
  28620    S ^XTMP(" VPRYFRP"," SEQUENCE", START)=NAM E
  28621   "RTN","VPR YFRP",37,0 )
  28622    S VDATE=+ (START_"00 "),STOP=+( START_"99" )
  28623   "RTN","VPR YFRP",38,0 )
  28624    F  S VDAT E=$O(^AUPN VSIT("B",V DATE))  Q: 'VDATE  Q: VDATE>STOP   D
  28625   "RTN","VPR YFRP",39,0 )
  28626    . S VISIT =0 F  S VI SIT=$O(^AU PNVSIT("B" ,VDATE,VIS IT)) Q:'VI SIT  D
  28627   "RTN","VPR YFRP",40,0 )
  28628    . . S X0= ^AUPNVSIT( VISIT,0),D FN=$P(X0," ^",5),CAT= $P(X0,"^", 7)
  28629   "RTN","VPR YFRP",41,0 )
  28630    . . Q:$D( ^XTMP("VPR YFRP","FOU ND",DFN))
  28631   "RTN","VPR YFRP",42,0 )
  28632    . . Q:CAT ="E"  ; ev ent (histo rical)
  28633   "RTN","VPR YFRP",43,0 )
  28634    . . Q:CAT ="N"  ; no t found
  28635   "RTN","VPR YFRP",44,0 )
  28636    . . S ^XT MP("VPRYFR P","MONTH" ,NAME,DFN) =""
  28637   "RTN","VPR YFRP",45,0 )
  28638    . . S ^XT MP("VPRYFR P","FOUND" ,DFN)=""
  28639   "RTN","VPR YFRP",46,0 )
  28640    Q
  28641   "RTN","VPR YFRP",47,0 )
  28642   XTRLST ; P rompt for  a list nam e and extr act it int eractively
  28643   "RTN","VPR YFRP",48,0 )
  28644    N DIR,DTO UT,DUOUT,D IRUT,DIROU T,X,Y,DA,F ROMSYS,TOS YS
  28645   "RTN","VPR YFRP",49,0 )
  28646    S DIR(0)= "D^::EMP", DIR("A")=" Extract Mo nth",DIR(" ?")="Enter  the month  to run an  extract."
  28647   "RTN","VPR YFRP",50,0 )
  28648    D ^DIR I  $D(DIRUT)  Q
  28649   "RTN","VPR YFRP",51,0 )
  28650    N VPRYNAM E S VPRYNA ME=$$EXTMT H(Y)
  28651   "RTN","VPR YFRP",52,0 )
  28652    W !,"Runn ing Extrac ts for "_V PRYNAME_".   Continue ? NO// " R  X:300
  28653   "RTN","VPR YFRP",53,0 )
  28654    I $E($$UP ^XLFSTR(X) )'="Y" Q
  28655   "RTN","VPR YFRP",54,0 )
  28656    W !
  28657   "RTN","VPR YFRP",55,0 )
  28658    D GET4LST
  28659   "RTN","VPR YFRP",56,0 )
  28660    Q
  28661   "RTN","VPR YFRP",57,0 )
  28662   GET4ALL ;  Extract da ta for all  lists
  28663   "RTN","VPR YFRP",58,0 )
  28664    ; VARIABL ES THAT CO NTROL EXTR ACT PROCES S
  28665   "RTN","VPR YFRP",59,0 )
  28666    ; VPRYNAM E: name of  month for  which pat ients are  being extr acted
  28667   "RTN","VPR YFRP",60,0 )
  28668    ; VPRYDFN  : current  DFN in th e month
  28669   "RTN","VPR YFRP",61,0 )
  28670    ; VPRYDOM S: domains  for which  extracts  will be do ne
  28671   "RTN","VPR YFRP",62,0 )
  28672    ; VPRYDOM  : current  DOMAIN fo r extract
  28673   "RTN","VPR YFRP",63,0 )
  28674    ; these v ariables g et saved b efore each  extract s o KILL^XUS CLEAN may  be called
  28675   "RTN","VPR YFRP",64,0 )
  28676    N VPRYNAM E,X
  28677   "RTN","VPR YFRP",65,0 )
  28678    W !,"Queu e each lis t?  NO// "  R X:300
  28679   "RTN","VPR YFRP",66,0 )
  28680    I $E($$UP ^XLFSTR(X) )="Y" N VP RYQ,LASTPT ,VPRDTH S  VPRYQ=1,LA STPT=0
  28681   "RTN","VPR YFRP",67,0 )
  28682    S VPRYNAM E=""
  28683   "RTN","VPR YFRP",68,0 )
  28684    F  S VPRY NAME=$O(^X TMP("VPRYF RP","MONTH ",VPRYNAME )) Q:VPRYN AME=""  D
  28685   "RTN","VPR YFRP",69,0 )
  28686    . I $G(VP RYQ) D  Q
  28687   "RTN","VPR YFRP",70,0 )
  28688    . . S VPR DTH=$$HADD ^XLFDT($H, ,LASTPT\10 00)
  28689   "RTN","VPR YFRP",71,0 )
  28690    . . D QU4 LST
  28691   "RTN","VPR YFRP",72,0 )
  28692    . . S LAS TPT=LASTPT +^XTMP("VP RYFRP","co unt",VPRYN AME)
  28693   "RTN","VPR YFRP",73,0 )
  28694    . E  D
  28695   "RTN","VPR YFRP",74,0 )
  28696    . . W !," Running ex tracts for  "_VPRYNAM E
  28697   "RTN","VPR YFRP",75,0 )
  28698    . . D GET 4LST
  28699   "RTN","VPR YFRP",76,0 )
  28700    Q
  28701   "RTN","VPR YFRP",77,0 )
  28702   STOP ; Sto p queued j obs
  28703   "RTN","VPR YFRP",78,0 )
  28704    S ^XTMP(" VPRYFRP"," STOP")=1
  28705   "RTN","VPR YFRP",79,0 )
  28706    Q
  28707   "RTN","VPR YFRP",80,0 )
  28708    ;
  28709   "RTN","VPR YFRP",81,0 )
  28710   QU4LST ; Q ueue extra ct of a mo nth
  28711   "RTN","VPR YFRP",82,0 )
  28712    ; expects  VPRYNAME  from GET4A LL
  28713   "RTN","VPR YFRP",83,0 )
  28714    N ZTRTN,Z TDESC,ZTDT H,ZTIO,ZTU CI,ZTCPU,Z TPRI,ZTSAV E,ZTKIL,ZT SYNC,ZTSK
  28715   "RTN","VPR YFRP",84,0 )
  28716    S ZTRTN=" GET4LST^VP RYFRP",ZTI O="",ZTSAV E("VPRYNAM E")="",ZTD TH=VPRDTH
  28717   "RTN","VPR YFRP",85,0 )
  28718    S ZTDESC= "Measure e xtract siz es for pat ients with  visits in  a month"
  28719   "RTN","VPR YFRP",86,0 )
  28720    D ^%ZTLOA D I '$G(ZT SK) W !,"E rror queui ng "_VPRYN AME
  28721   "RTN","VPR YFRP",87,0 )
  28722    S ^XTMP(" VPRYFRP"," TASKS",VPR YNAME)="Ta sk #"_ZTSK
  28723   "RTN","VPR YFRP",88,0 )
  28724    S ^XTMP(" VPRYFRP"," TASKS",VPR YNAME,"sta tus")="Que ued"
  28725   "RTN","VPR YFRP",89,0 )
  28726    S ^XTMP(" VPRYFRP"," TASKS",VPR YNAME,"cou nt")=0
  28727   "RTN","VPR YFRP",90,0 )
  28728    S ^XTMP(" VPRYFRP"," TASKS",VPR YNAME,"res ult")=""
  28729   "RTN","VPR YFRP",91,0 )
  28730    W !,VPRYN AME,", tas k #"_ZTSK_ " queued f or "_$$HTE ^XLFDT(VPR DTH)
  28731   "RTN","VPR YFRP",92,0 )
  28732    Q
  28733   "RTN","VPR YFRP",93,0 )
  28734   GET4LST ;  Extract da ta for a l ist & meas ure size
  28735   "RTN","VPR YFRP",94,0 )
  28736    ; expects  VPRYNAME  from GET4A LL or XTRL ST or Queu ed Job
  28737   "RTN","VPR YFRP",95,0 )
  28738    N VPRYDFN ,VPRYH,VPR YDOMS,PTSI ZE,VPRFZTS K
  28739   "RTN","VPR YFRP",96,0 )
  28740    D BLDDOMS (.VPRYDOMS )
  28741   "RTN","VPR YFRP",97,0 )
  28742    S VPRYH=$ H
  28743   "RTN","VPR YFRP",98,0 )
  28744    S VPRFZTS K=$G(ZTSK)  ; if task ed, VPRDJ  expects VP RFZTSK to  be task
  28745   "RTN","VPR YFRP",99,0 )
  28746    S ^XTMP(" VPRYFRP"," TASKS",VPR YNAME,"sta tus")="Sta rted"
  28747   "RTN","VPR YFRP",100, 0)
  28748    S VPRYDFN =0 F  S VP RYDFN=$O(^ XTMP("VPRY FRP","MONT H",VPRYNAM E,VPRYDFN) ) Q:'VPRYD FN  D
  28749   "RTN","VPR YFRP",101, 0)
  28750    . S PTSIZ E=$$SIZEPT (VPRYDFN)
  28751   "RTN","VPR YFRP",102, 0)
  28752    . S ^XTMP ("VPRYFRP" ,"MONTH",V PRYNAME,VP RYDFN)=PTS IZE
  28753   "RTN","VPR YFRP",103, 0)
  28754    . D TOPSI ZE(VPRYDFN ,"",PTSIZE ,"PatientS ize")
  28755   "RTN","VPR YFRP",104, 0)
  28756    S ^XTMP(" VPRYFRP"," MONTH",VPR YNAME)=$$H DIFF^XLFDT ($H,VPRYH, 2)
  28757   "RTN","VPR YFRP",105, 0)
  28758    S ^XTMP(" VPRYFRP"," TASKS",VPR YNAME,"sta tus")="Fin ished"
  28759   "RTN","VPR YFRP",106, 0)
  28760    Q
  28761   "RTN","VPR YFRP",107, 0)
  28762   SIZEPT(VPR YDFN) ; Ex tract data  for a pat ient and r eturn size
  28763   "RTN","VPR YFRP",108, 0)
  28764    I '$D(ZTQ UEUED) W " ."
  28765   "RTN","VPR YFRP",109, 0)
  28766    N VPRYSIZ E,VPRYDOM, VPRBATCH,V PRYET,DOMS IZE
  28767   "RTN","VPR YFRP",110, 0)
  28768    S VPRYSIZ E=0,VPRBAT CH="VPRYFR P"
  28769   "RTN","VPR YFRP",111, 0)
  28770    S VPRYDOM ="" F  S V PRYDOM=$O( VPRYDOMS(V PRYDOM)) Q :VPRYDOM=" "  D
  28771   "RTN","VPR YFRP",112, 0)
  28772    . D CLEAN DOM
  28773   "RTN","VPR YFRP",113, 0)
  28774    . S VPRYE T=$H
  28775   "RTN","VPR YFRP",114, 0)
  28776    . S DOMSI ZE=$$SIZED OM(VPRYDFN ,VPRYDOM)
  28777   "RTN","VPR YFRP",115, 0)
  28778    . S VPRYE T=$$HDIFF^ XLFDT($H,V PRYET,2)
  28779   "RTN","VPR YFRP",116, 0)
  28780    . S VPRYS IZE=VPRYSI ZE+DOMSIZE
  28781   "RTN","VPR YFRP",117, 0)
  28782    . D TOPSI ZE(VPRYDFN ,VPRYDOM,V PRYET,"Ext ractTime")
  28783   "RTN","VPR YFRP",118, 0)
  28784    . D TOPSI ZE(VPRYDFN ,VPRYDOM,D OMSIZE,"Ex tractSize" )
  28785   "RTN","VPR YFRP",119, 0)
  28786    Q VPRYSIZ E
  28787   "RTN","VPR YFRP",120, 0)
  28788    ;
  28789   "RTN","VPR YFRP",121, 0)
  28790   SIZEDOM(DF N,DOMAIN)  ; Extract  1 domain a nd return  size
  28791   "RTN","VPR YFRP",122, 0)
  28792    N $ESTACK ,$ETRAP S  $ETRAP="D  EXTERR^VPR YFRP"
  28793   "RTN","VPR YFRP",123, 0)
  28794    Q:$G(^XTM P("VPRYFRP ","STOP")) =1 0
  28795   "RTN","VPR YFRP",124, 0)
  28796    N FILTER, RSLT,SIZE
  28797   "RTN","VPR YFRP",125, 0)
  28798    S FILTER( "patientId ")=DFN
  28799   "RTN","VPR YFRP",126, 0)
  28800    S FILTER( "domain")= DOMAIN
  28801   "RTN","VPR YFRP",127, 0)
  28802    D GET^VPR DJ(.RSLT,. FILTER)
  28803   "RTN","VPR YFRP",128, 0)
  28804    S SIZE=$$ SIZEREF(RS LT)
  28805   "RTN","VPR YFRP",129, 0)
  28806    S ^XTMP(" VPRYFRP"," TASKS",VPR YNAME,"cou nt")=$G(^X TMP("VPRYF RP","TASKS ",VPRYNAME ,"count")) +1
  28807   "RTN","VPR YFRP",130, 0)
  28808    S ^XTMP(" VPRYFRP"," TASKS",VPR YNAME,"res ult")=RSLT
  28809   "RTN","VPR YFRP",131, 0)
  28810    K @RSLT ; ^XTMP("VPR YFRP",VPRY DFN,VPRYDO M)
  28811   "RTN","VPR YFRP",132, 0)
  28812    Q SIZE
  28813   "RTN","VPR YFRP",133, 0)
  28814    ;
  28815   "RTN","VPR YFRP",134, 0)
  28816   CLEANDOM ;  Clean up  partition  for domain  extract
  28817   "RTN","VPR YFRP",135, 0)
  28818    N X
  28819   "RTN","VPR YFRP",136, 0)
  28820    K ^TMP("V PRY",$J)
  28821   "RTN","VPR YFRP",137, 0)
  28822    F X="VPRY NAME","VPR YDOMS","VP RYDFN","VP RYDOM","VP RYSIZE","V PRYH","VPR BATCH","VP RFZTSK" M  ^TMP("VPRY ",$J,X)=@X
  28823   "RTN","VPR YFRP",138, 0)
  28824    D KILL^XU SCLEAN
  28825   "RTN","VPR YFRP",139, 0)
  28826    F X="VPRY NAME","VPR YDOMS","VP RYDFN","VP RYDOM","VP RYSIZE","V PRYH","VPR BATCH","VP RFZTSK" M  @X=^TMP("V PRY",$J,X)
  28827   "RTN","VPR YFRP",140, 0)
  28828    K ^TMP("V PRY",$J)
  28829   "RTN","VPR YFRP",141, 0)
  28830    Q
  28831   "RTN","VPR YFRP",142, 0)
  28832   TOPSIZE(DF N,DOMAIN,S IZE,MEASUR E) ; Recor d the high est measur es (time,  size)
  28833   "RTN","VPR YFRP",143, 0)
  28834    Q:SIZE<1
  28835   "RTN","VPR YFRP",144, 0)
  28836    N LOW,NUM ,MAX,DFNS, DOMS
  28837   "RTN","VPR YFRP",145, 0)
  28838    S MAX=30
  28839   "RTN","VPR YFRP",146, 0)
  28840    S LOW=+$O (^XTMP("VP RYFRP","ME ASURE",MEA SURE,"")), NUM=$G(^XT MP("VPRYFR P","MEASUR E",MEASURE ),0)
  28841   "RTN","VPR YFRP",147, 0)
  28842    I SIZE>LO W S ^XTMP( "VPRYFRP", "MEASURE", MEASURE,SI ZE,DFN,$S( $L(DOMAIN) :DOMAIN,1: 0))="",NUM =NUM+1
  28843   "RTN","VPR YFRP",148, 0)
  28844    I NUM>MAX  D
  28845   "RTN","VPR YFRP",149, 0)
  28846    . S LOW=" " F  S LOW =$O(^XTMP( "VPRYFRP", "MEASURE", MEASURE,LO W)) Q:'LOW   D  Q:NUM '>MAX
  28847   "RTN","VPR YFRP",150, 0)
  28848    . . S DFN S="" F  S  DFNS=$O(^X TMP("VPRYF RP","MEASU RE",MEASUR E,LOW,DFNS )) Q:'DFNS   D  Q:NUM '>MAX
  28849   "RTN","VPR YFRP",151, 0)
  28850    . . . S D OMS="" F   S DOMS=$O( ^XTMP("VPR YFRP","MEA SURE",MEAS URE,LOW,DF NS,DOMS))  Q:DOMS=""   D  Q:NUM' >MAX
  28851   "RTN","VPR YFRP",152, 0)
  28852    . . . . S  NUM=NUM-1  K ^XTMP(" VPRYFRP"," MEASURE",M EASURE,LOW ,DFNS,DOMS )
  28853   "RTN","VPR YFRP",153, 0)
  28854    S ^XTMP(" VPRYFRP"," MEASURE",M EASURE)=NU M
  28855   "RTN","VPR YFRP",154, 0)
  28856    Q
  28857   "RTN","VPR YFRP",155, 0)
  28858   EXTERR ; C ome here i n case of  error duri ng extract
  28859   "RTN","VPR YFRP",156, 0)
  28860    S ^XTMP(" VPRYFRP"," ERRORS",$G (VPRYDFN,0 ),$G(VPRYD OM,0))=$H
  28861   "RTN","VPR YFRP",157, 0)
  28862    I $D(ZTQU EUED),$L($ G(VPRYDFN) ),$L($G(VP RYDOM)) K  ^XTMP("VPR YFRP",VPRY DFN,VPRYDO M)
  28863   "RTN","VPR YFRP",158, 0)
  28864    D ^%ZTER
  28865   "RTN","VPR YFRP",159, 0)
  28866    G UNWIND^ %ZTER
  28867   "RTN","VPR YFRP",160, 0)
  28868    ;
  28869   "RTN","VPR YFRP",161, 0)
  28870   SIZEREF(RE F) ; Retur n size of  date in re f
  28871   "RTN","VPR YFRP",162, 0)
  28872    N X,SIZE, ROOT,LROOT
  28873   "RTN","VPR YFRP",163, 0)
  28874    S SIZE=0
  28875   "RTN","VPR YFRP",164, 0)
  28876    S ROOT=$R E($P($RE(R EF),")",2, 99)),LROOT =$L(ROOT)
  28877   "RTN","VPR YFRP",165, 0)
  28878    S X=REF F   S X=$Q(@ X) Q:$E(X, 1,LROOT)'= ROOT  S SI ZE=SIZE+$L (@X)
  28879   "RTN","VPR YFRP",166, 0)
  28880    Q SIZE
  28881   "RTN","VPR YFRP",167, 0)
  28882    ;
  28883   "RTN","VPR YFRP",168, 0)
  28884   SHOWCNT ;  Show count s of uniqu e patients  by month
  28885   "RTN","VPR YFRP",169, 0)
  28886    N NAME,IM ONTH,CNT,D FN,TOTAL
  28887   "RTN","VPR YFRP",170, 0)
  28888    S TOTAL=0
  28889   "RTN","VPR YFRP",171, 0)
  28890    S IMONTH= 0 F  S IMO NTH=$O(^XT MP("VPRYFR P","SEQUEN CE",IMONTH )) Q:'IMON TH  D
  28891   "RTN","VPR YFRP",172, 0)
  28892    . S NAME= ^XTMP("VPR YFRP","SEQ UENCE",IMO NTH)
  28893   "RTN","VPR YFRP",173, 0)
  28894    . S CNT=0
  28895   "RTN","VPR YFRP",174, 0)
  28896    . S DFN=0  F  S DFN= $O(^XTMP(" VPRYFRP"," MONTH",NAM E,DFN)) Q: 'DFN  S CN T=CNT+1
  28897   "RTN","VPR YFRP",175, 0)
  28898    . W !,NAM E,?12,CNT, " patients "
  28899   "RTN","VPR YFRP",176, 0)
  28900    . S ^XTMP ("VPRYFRP" ,"count",N AME)=CNT
  28901   "RTN","VPR YFRP",177, 0)
  28902    . S TOTAL =TOTAL+CNT
  28903   "RTN","VPR YFRP",178, 0)
  28904    W !!,"Tot al",?11,TO TAL," pati ents"
  28905   "RTN","VPR YFRP",179, 0)
  28906    Q
  28907   "RTN","VPR YFRP",180, 0)
  28908   SHOWSIZE ;  Show extr act sizes  by month
  28909   "RTN","VPR YFRP",181, 0)
  28910    N NAME,IM ONTH,SIZE, DFN,SECS
  28911   "RTN","VPR YFRP",182, 0)
  28912    S IMONTH= 0 F  S IMO NTH=$O(^XT MP("VPRYFR P","SEQUEN CE",IMONTH )) Q:'IMON TH  D
  28913   "RTN","VPR YFRP",183, 0)
  28914    . S NAME= ^XTMP("VPR YFRP","SEQ UENCE",IMO NTH)
  28915   "RTN","VPR YFRP",184, 0)
  28916    . S SIZE= 0
  28917   "RTN","VPR YFRP",185, 0)
  28918    . S DFN=0  F  S DFN= $O(^XTMP(" VPRYFRP"," MONTH",NAM E,DFN)) Q: 'DFN  S SI ZE=SIZE+^X TMP("VPRYF RP","MONTH ",NAME,DFN )
  28919   "RTN","VPR YFRP",186, 0)
  28920    . S SECS= $G(^XTMP(" VPRYFRP"," MONTH",NAM E),0)
  28921   "RTN","VPR YFRP",187, 0)
  28922    . W !,NAM E,?12,SIZE ," bytes", ?30,SECS\6 0," minute s ",SECS#6 0," second s"
  28923   "RTN","VPR YFRP",188, 0)
  28924    Q
  28925   "RTN","VPR YFRP",189, 0)
  28926   SHOWSTS ;  Show task  status and  errors
  28927   "RTN","VPR YFRP",190, 0)
  28928    N DFN,DOM AIN,X
  28929   "RTN","VPR YFRP",191, 0)
  28930    S X="" F   S X=$O(^X TMP("VPRYF RP","TASKS ",X)) Q:X= ""  D
  28931   "RTN","VPR YFRP",192, 0)
  28932    . W !,X
  28933   "RTN","VPR YFRP",193, 0)
  28934    . W ?9,$G (^XTMP("VP RYFRP","TA SKS",X))
  28935   "RTN","VPR YFRP",194, 0)
  28936    . W ?25,$ G(^XTMP("V PRYFRP","T ASKS",X,"s tatus"))
  28937   "RTN","VPR YFRP",195, 0)
  28938    . W ?35,$ G(^XTMP("V PRYFRP","T ASKS",X,"c ount"))
  28939   "RTN","VPR YFRP",196, 0)
  28940    . ; W ?40 ,$G(^XTMP( "VPRYFRP", "TASKS",X, "result"))
  28941   "RTN","VPR YFRP",197, 0)
  28942    ;
  28943   "RTN","VPR YFRP",198, 0)
  28944    W !,"Erro rs (if any ) --"
  28945   "RTN","VPR YFRP",199, 0)
  28946    S DFN=""  F  S DFN=$ O(^XTMP("V PRYFRP","E RRORS",DFN )) Q:'DFN   D
  28947   "RTN","VPR YFRP",200, 0)
  28948    . S DOMAI N="" F  S  DOMAIN=$O( ^XTMP("VPR YFRP","ERR ORS",DFN,D OMAIN)) Q: DOMAIN=""   D
  28949   "RTN","VPR YFRP",201, 0)
  28950    . . W !,D FN,?20,DOM AIN,?45,$$ HTE^XLFDT( ^XTMP("VPR YFRP","ERR ORS",DFN,D OMAIN))
  28951   "RTN","VPR YFRP",202, 0)
  28952    Q
  28953   "RTN","VPR YFRP",203, 0)
  28954   SHOWTOP ;  Show large st sizes a nd times
  28955   "RTN","VPR YFRP",204, 0)
  28956    N MEASURE ,SIZE,DFN, DOMAIN,I
  28957   "RTN","VPR YFRP",205, 0)
  28958    F MEASURE ="PatientS ize","Extr actSize"," ExtractTim e" D
  28959   "RTN","VPR YFRP",206, 0)
  28960    . W !,MEA SURE," " F  I=1:1:24  W "-"
  28961   "RTN","VPR YFRP",207, 0)
  28962    . W !,"DF N",?15,$S( MEASURE["T ime":"Seco nds",1:"By tes")
  28963   "RTN","VPR YFRP",208, 0)
  28964    . I MEASU RE'="Patie ntSize" W  ?30,"Domai n"
  28965   "RTN","VPR YFRP",209, 0)
  28966    . S SIZE= 0 F  S SIZ E=$O(^XTMP ("VPRYFRP" ,"MEASURE" ,MEASURE,S IZE)) Q:'S IZE  D
  28967   "RTN","VPR YFRP",210, 0)
  28968    . . S DFN =0 F  S DF N=$O(^XTMP ("VPRYFRP" ,"MEASURE" ,MEASURE,S IZE,DFN))  Q:'DFN  D
  28969   "RTN","VPR YFRP",211, 0)
  28970    . . . S D OMAIN="" F   S DOMAIN =$O(^XTMP( "VPRYFRP", "MEASURE", MEASURE,SI ZE,DFN,DOM AIN)) Q:DO MAIN=""  D
  28971   "RTN","VPR YFRP",212, 0)
  28972    . . . . W  !,DFN,?15 ,SIZE
  28973   "RTN","VPR YFRP",213, 0)
  28974    . . . . I  DOMAIN'=0  W ?30,DOM AIN
  28975   "RTN","VPR YFRP",214, 0)
  28976    . W !
  28977   "RTN","VPR YFRP",215, 0)
  28978    Q
  28979   "RTN","VPR YFRP",216, 0)
  28980   EXTMTH(DT)  ; Return  external M mmYYYY for mat
  28981   "RTN","VPR YFRP",217, 0)
  28982    N M,Y
  28983   "RTN","VPR YFRP",218, 0)
  28984    S M=$E(DT ,4,5),Y=$E (DT,1,3)
  28985   "RTN","VPR YFRP",219, 0)
  28986    S Y=Y+170 0
  28987   "RTN","VPR YFRP",220, 0)
  28988    S M=$P($P ($T(MNAMES ),";;",2,9 9),";",M)
  28989   "RTN","VPR YFRP",221, 0)
  28990    Q M_Y
  28991   "RTN","VPR YFRP",222, 0)
  28992    ;
  28993   "RTN","VPR YFRP",223, 0)
  28994   INCMTH(DT)  ; Return  incremente d month
  28995   "RTN","VPR YFRP",224, 0)
  28996    N M,Y
  28997   "RTN","VPR YFRP",225, 0)
  28998    S M=$E(DT ,4,5),Y=$E (DT,1,3)
  28999   "RTN","VPR YFRP",226, 0)
  29000    S M=M+1
  29001   "RTN","VPR YFRP",227, 0)
  29002    I M>12 S  M=1,Y=Y+1
  29003   "RTN","VPR YFRP",228, 0)
  29004    I $L(Y)'= 3 W !,"err or in year " Q 99999
  29005   "RTN","VPR YFRP",229, 0)
  29006    S M="00"_ M,M=$E(M,$ L(M)-1,$L( M))
  29007   "RTN","VPR YFRP",230, 0)
  29008    Q Y_M
  29009   "RTN","VPR YFRP",231, 0)
  29010    ;
  29011   "RTN","VPR YFRP",232, 0)
  29012   PRMTMTHS(B EG,END) ;  prompt for  the month  range
  29013   "RTN","VPR YFRP",233, 0)
  29014    N DIR,DTO UT,DUOUT,D IRUT,DIROU T,X,Y,DA,F ROMSYS,TOS YS
  29015   "RTN","VPR YFRP",234, 0)
  29016    S DIR(0)= "D^::EMP", DIR("A")=" Beginning  Month",DIR ("?")="Ent er the ear liest mont h of visit s to evalu ate."
  29017   "RTN","VPR YFRP",235, 0)
  29018    D ^DIR I  $D(DIRUT)  S BEG="",E ND="" Q
  29019   "RTN","VPR YFRP",236, 0)
  29020    S BEG=Y
  29021   "RTN","VPR YFRP",237, 0)
  29022    S DIR(0)= "D^::EMP", DIR("A")=" Ending Mon th",DIR("? ")="Enter  the latest  month of  visits to  evaluate."
  29023   "RTN","VPR YFRP",238, 0)
  29024    D ^DIR I  $D(DIRUT)  S BEG="",E ND="" Q
  29025   "RTN","VPR YFRP",239, 0)
  29026    S END=Y
  29027   "RTN","VPR YFRP",240, 0)
  29028    W !,"Sear ching visi ts from ", $$FMTE^XLF DT(BEG),"  through ", $$FMTE^XLF DT(END),".   Continue ? NO// " R  X:300
  29029   "RTN","VPR YFRP",241, 0)
  29030    I $E($$UP ^XLFSTR(X) )'="Y" S B EG="",END= "" Q
  29031   "RTN","VPR YFRP",242, 0)
  29032    S BEG=$E( BEG,1,5),E ND=$E(END, 1,5)
  29033   "RTN","VPR YFRP",243, 0)
  29034    Q
  29035   "RTN","VPR YFRP",244, 0)
  29036   BLDDOMS(DO MAINS) ; B uild a lis t of domai ns
  29037   "RTN","VPR YFRP",245, 0)
  29038    N X
  29039   "RTN","VPR YFRP",246, 0)
  29040    F I=1:1 S  X=$P($T(D OMAINS+I), ";;",2) Q: X="zzzzz"   S DOMAINS (X)=""
  29041   "RTN","VPR YFRP",247, 0)
  29042    Q
  29043   "RTN","VPR YFRP",248, 0)
  29044   MNAMES ;;J an;Feb;Mar ;Apr;May;J un;Jul;Aug ;Sep;Oct;N ov;Dec
  29045   "RTN","VPR YFRP",249, 0)
  29046    ;
  29047   "RTN","VPR YFRP",250, 0)
  29048   DOMAINS ;
  29049   "RTN","VPR YFRP",251, 0)
  29050    ;;allergy
  29051   "RTN","VPR YFRP",252, 0)
  29052    ;;auxilia ry
  29053   "RTN","VPR YFRP",253, 0)
  29054    ;;appoint ment
  29055   "RTN","VPR YFRP",254, 0)
  29056    ;;diagnos is
  29057   "RTN","VPR YFRP",255, 0)
  29058    ;;documen t
  29059   "RTN","VPR YFRP",256, 0)
  29060    ;;factor
  29061   "RTN","VPR YFRP",257, 0)
  29062    ;;immuniz ation
  29063   "RTN","VPR YFRP",258, 0)
  29064    ;;lab
  29065   "RTN","VPR YFRP",259, 0)
  29066    ;;med
  29067   "RTN","VPR YFRP",260, 0)
  29068    ;;obs
  29069   "RTN","VPR YFRP",261, 0)
  29070    ;;order
  29071   "RTN","VPR YFRP",262, 0)
  29072    ;;problem
  29073   "RTN","VPR YFRP",263, 0)
  29074    ;;procedu re
  29075   "RTN","VPR YFRP",264, 0)
  29076    ;;consult
  29077   "RTN","VPR YFRP",265, 0)
  29078    ;;image
  29079   "RTN","VPR YFRP",266, 0)
  29080    ;;surgery
  29081   "RTN","VPR YFRP",267, 0)
  29082    ;;task
  29083   "RTN","VPR YFRP",268, 0)
  29084    ;;visit
  29085   "RTN","VPR YFRP",269, 0)
  29086    ;;vital
  29087   "RTN","VPR YFRP",270, 0)
  29088    ;;mh
  29089   "RTN","VPR YFRP",271, 0)
  29090    ;;ptf
  29091   "RTN","VPR YFRP",272, 0)
  29092    ;;exam
  29093   "RTN","VPR YFRP",273, 0)
  29094    ;;cpt
  29095   "RTN","VPR YFRP",274, 0)
  29096    ;;educati on
  29097   "RTN","VPR YFRP",275, 0)
  29098    ;;pov
  29099   "RTN","VPR YFRP",276, 0)
  29100    ;;skin
  29101   "RTN","VPR YFRP",277, 0)
  29102    ;;treatme nt
  29103   "RTN","VPR YFRP",278, 0)
  29104    ;;roadtri p
  29105   "RTN","VPR YFRP",279, 0)
  29106    ;;zzzzz
  29107   "RTN","VPR YFRP1")
  29108   0^103^B463 98226
  29109   "RTN","VPR YFRP1",1,0 )
  29110   VPRYFRP1 ; SLC/KCM --  Find rece nt patient s by week  and test e xtracts
  29111   "RTN","VPR YFRP1",2,0 )
  29112    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  29113   "RTN","VPR YFRP1",3,0 )
  29114    ;
  29115   "RTN","VPR YFRP1",4,0 )
  29116   EN ; Utili ties for b uilding ro ster lists
  29117   "RTN","VPR YFRP1",5,0 )
  29118    W !,"D BL DWKS to cr eate lists  of new pa tients by  week"
  29119   "RTN","VPR YFRP1",6,0 )
  29120    W !,"D EX TRACT to s tart queui ng extract s"
  29121   "RTN","VPR YFRP1",7,0 )
  29122    W !,"D SH OWCNT to s ee how man y new pati ents in ea ch week"
  29123   "RTN","VPR YFRP1",8,0 )
  29124    W !,"D SH OWSIZE to  show size  & elapsed  time for e ach week"
  29125   "RTN","VPR YFRP1",9,0 )
  29126    W !,"D SH OWSTS to s how task s tatus and  any errors  in extrac ts"
  29127   "RTN","VPR YFRP1",10, 0)
  29128    W !,"D SH OWTOP to s how the hi ghest time s and size s"
  29129   "RTN","VPR YFRP1",11, 0)
  29130    W !,"D ST OP to stop  processin g of extra cts"
  29131   "RTN","VPR YFRP1",12, 0)
  29132    W !!,"Dat a is store d in ^XTMP (""VPRYFRP "")",!
  29133   "RTN","VPR YFRP1",13, 0)
  29134    Q
  29135   "RTN","VPR YFRP1",14, 0)
  29136    ;
  29137   "RTN","VPR YFRP1",15, 0)
  29138    ; ^XTMP(" VPRYFRP",d fn,domain, ...extract  data...) 
  29139   "RTN","VPR YFRP1",16, 0)
  29140    ; ^XTMP(" VPRYFRP"," FOUND",dfn )
  29141   "RTN","VPR YFRP1",17, 0)
  29142    ; ^XTMP(" VPRYFRP"," MEASURE",t ype,size,d fn,{domain })
  29143   "RTN","VPR YFRP1",18, 0)
  29144    ; ^XTMP(" VPRYFRP"," TASKS",tas kId,...)
  29145   "RTN","VPR YFRP1",19, 0)
  29146    ; ^XTMP(" VPRYFRP"," TOTALS","p atients")
  29147   "RTN","VPR YFRP1",20, 0)
  29148    ; ^XTMP(" VPRYFRP"," WEEK",date ,dfn)=byte Count
  29149   "RTN","VPR YFRP1",21, 0)
  29150    ;
  29151   "RTN","VPR YFRP1",22, 0)
  29152   BLDWKS ; B uild patie nt lists f or a range  of weeks
  29153   "RTN","VPR YFRP1",23, 0)
  29154    ; ^XTMP(" VPRYFRP"," FOUND",DFN )=""          ; patie nts alread y found
  29155   "RTN","VPR YFRP1",24, 0)
  29156    ; ^XTMP(" VPRYFRP"," WEEK",FMDa te,DFN)=""    ; patie nts by wee k of visit
  29157   "RTN","VPR YFRP1",25, 0)
  29158    D NEWXTMP ^VPRDJFS(" VPRYFRP",9 0,"VPR Ext ract Patie nts by Wee k")
  29159   "RTN","VPR YFRP1",26, 0)
  29160    S ^XTMP(" VPRYFRP"," TOTALS","p atients")= 0
  29161   "RTN","VPR YFRP1",27, 0)
  29162    ;
  29163   "RTN","VPR YFRP1",28, 0)
  29164    N BEG,END ,WEEK
  29165   "RTN","VPR YFRP1",29, 0)
  29166    D PRMTWKS (.BEG,.END ) Q:'BEG   Q:'END
  29167   "RTN","VPR YFRP1",30, 0)
  29168    S WEEK=BE G F  D BLD WEEK(WEEK)  S WEEK=$$ FMADD^XLFD T(WEEK,7)  Q:WEEK>END
  29169   "RTN","VPR YFRP1",31, 0)
  29170    D SHOWCNT
  29171   "RTN","VPR YFRP1",32, 0)
  29172    Q
  29173   "RTN","VPR YFRP1",33, 0)
  29174   BLDWEEK(SU NDAY) ; Bu ild list o f patients  for the w eek starti ng SUNDAY
  29175   "RTN","VPR YFRP1",34, 0)
  29176    N VDATE,E OW,IEN,X0, CAT,COUNT
  29177   "RTN","VPR YFRP1",35, 0)
  29178    S COUNT=0
  29179   "RTN","VPR YFRP1",36, 0)
  29180    S EOW=$$F MADD^XLFDT (SUNDAY,7) _".9999"      ; to in clude all  Saturday
  29181   "RTN","VPR YFRP1",37, 0)
  29182    S VDATE=$ $FMADD^XLF DT(SUNDAY, -1)_".9999 "  ; to ge t entries  with no ti me
  29183   "RTN","VPR YFRP1",38, 0)
  29184    F  S VDAT E=$O(^AUPN VSIT("B",V DATE)) Q:' VDATE  Q:V DATE>EOW   D
  29185   "RTN","VPR YFRP1",39, 0)
  29186    . S IEN=0  F  S IEN= $O(^AUPNVS IT("B",VDA TE,IEN)) Q :'IEN  D
  29187   "RTN","VPR YFRP1",40, 0)
  29188    . . S X0= ^AUPNVSIT( IEN,0),DFN =$P(X0,"^" ,5),CAT=$P (X0,"^",7)
  29189   "RTN","VPR YFRP1",41, 0)
  29190    . . Q:$D( ^XTMP("VPR YFRP","FOU ND",DFN))
  29191   "RTN","VPR YFRP1",42, 0)
  29192    . . Q:CAT ="E"  ; ev ent (histo rical)
  29193   "RTN","VPR YFRP1",43, 0)
  29194    . . Q:CAT ="N"  ; no t found
  29195   "RTN","VPR YFRP1",44, 0)
  29196    . . S COU NT=COUNT+1
  29197   "RTN","VPR YFRP1",45, 0)
  29198    . . S ^XT MP("VPRYFR P","FOUND" ,DFN)=""
  29199   "RTN","VPR YFRP1",46, 0)
  29200    . . S ^XT MP("VPRYFR P","WEEK", SUNDAY,DFN )=""
  29201   "RTN","VPR YFRP1",47, 0)
  29202    S ^XTMP(" VPRYFRP"," WEEK",SUND AY,"count" )=COUNT
  29203   "RTN","VPR YFRP1",48, 0)
  29204    S ^XTMP(" VPRYFRP"," TOTALS","p atients")= ^XTMP("VPR YFRP","TOT ALS","pati ents")+COU NT
  29205   "RTN","VPR YFRP1",49, 0)
  29206    Q
  29207   "RTN","VPR YFRP1",50, 0)
  29208   EXTRACT ;  Begin firs t extract  by week
  29209   "RTN","VPR YFRP1",51, 0)
  29210    N TASK,VP RYWEEK
  29211   "RTN","VPR YFRP1",52, 0)
  29212    S VPRYWEE K=$O(^XTMP ("VPRYFRP" ,"WEEK",0) )
  29213   "RTN","VPR YFRP1",53, 0)
  29214    I 'VPRYWE EK W !,"No  lists by  week" QUIT
  29215   "RTN","VPR YFRP1",54, 0)
  29216    W !,"Queu ing week " ,$$FMTE^XL FDT(VPRYWE EK)
  29217   "RTN","VPR YFRP1",55, 0)
  29218    S TASK=$$ QWEEK(VPRY WEEK) W "  task ",TAS K
  29219   "RTN","VPR YFRP1",56, 0)
  29220    Q
  29221   "RTN","VPR YFRP1",57, 0)
  29222   STOP ; Sto p queued j obs
  29223   "RTN","VPR YFRP1",58, 0)
  29224    S ^XTMP(" VPRYFRP"," STOP")=1
  29225   "RTN","VPR YFRP1",59, 0)
  29226    Q
  29227   "RTN","VPR YFRP1",60, 0)
  29228   QWEEK(VPRY WEEK) ; Qu eue extrac ts for VPR YWEEK
  29229   "RTN","VPR YFRP1",61, 0)
  29230    N ZTRTN,Z TDESC,ZTDT H,ZTIO,ZTU CI,ZTCPU,Z TPRI,ZTSAV E,ZTKIL,ZT SYNC,ZTSK
  29231   "RTN","VPR YFRP1",62, 0)
  29232    S ZTRTN=" GET4LST^VP RYFRP1",ZT IO="",ZTSA VE("VPRYWE EK")="",ZT DTH=$H
  29233   "RTN","VPR YFRP1",63, 0)
  29234    S ZTDESC= "Measure e xtract siz es for pat ients with  visits in  a week"
  29235   "RTN","VPR YFRP1",64, 0)
  29236    D ^%ZTLOA D I '$G(ZT SK) W !,"E rror queui ng "_VPRYW EEK
  29237   "RTN","VPR YFRP1",65, 0)
  29238    S ^XTMP(" VPRYFRP"," TASKS",VPR YWEEK)="Ta sk #"_ZTSK
  29239   "RTN","VPR YFRP1",66, 0)
  29240    S ^XTMP(" VPRYFRP"," TASKS",VPR YWEEK,"sta tus")="Que ued"
  29241   "RTN","VPR YFRP1",67, 0)
  29242    S ^XTMP(" VPRYFRP"," TASKS",VPR YWEEK,"cou nt")=0
  29243   "RTN","VPR YFRP1",68, 0)
  29244    S ^XTMP(" VPRYFRP"," TASKS",VPR YWEEK,"res ult")=""
  29245   "RTN","VPR YFRP1",69, 0)
  29246    Q ZTSK
  29247   "RTN","VPR YFRP1",70, 0)
  29248   GET4LST ;  Extract da ta for a l ist & meas ure size
  29249   "RTN","VPR YFRP1",71, 0)
  29250    ; expects  VPRYWEEK  (date of S unday for  the week)
  29251   "RTN","VPR YFRP1",72, 0)
  29252    N VPRYDFN ,VPRYH,VPR YDOMS,PTSI ZE,VPRFZTS K
  29253   "RTN","VPR YFRP1",73, 0)
  29254    D BLDDOMS ^VPRYFRP(. VPRYDOMS)
  29255   "RTN","VPR YFRP1",74, 0)
  29256    S VPRYH=$ H
  29257   "RTN","VPR YFRP1",75, 0)
  29258    S VPRFZTS K=$G(ZTSK)  ; if task ed, VPRDJ  expects VP RFZTSK to  be task id
  29259   "RTN","VPR YFRP1",76, 0)
  29260    S ^XTMP(" VPRYFRP"," TASKS",VPR YWEEK,"sta tus")="Sta rted"
  29261   "RTN","VPR YFRP1",77, 0)
  29262    S VPRYDFN =0 F  S VP RYDFN=$O(^ XTMP("VPRY FRP","WEEK ",VPRYWEEK ,VPRYDFN))  Q:'VPRYDF N  D
  29263   "RTN","VPR YFRP1",78, 0)
  29264    . S PTSIZ E=$$SIZEPT (VPRYDFN)
  29265   "RTN","VPR YFRP1",79, 0)
  29266    . S ^XTMP ("VPRYFRP" ,"WEEK",VP RYWEEK,VPR YDFN)=PTSI ZE
  29267   "RTN","VPR YFRP1",80, 0)
  29268    . D TOPSI ZE^VPRYFRP (VPRYDFN," ",PTSIZE," PatientSiz e")
  29269   "RTN","VPR YFRP1",81, 0)
  29270    S ^XTMP(" VPRYFRP"," WEEK",VPRY WEEK)=$$HD IFF^XLFDT( $H,VPRYH,2 ) ; elapse d time for  week
  29271   "RTN","VPR YFRP1",82, 0)
  29272    S ^XTMP(" VPRYFRP"," TASKS",VPR YWEEK,"sta tus")="Fin ished"
  29273   "RTN","VPR YFRP1",83, 0)
  29274    S VPRYWEE K=$O(^XTMP ("VPRYFRP" ,"WEEK",VP RYWEEK))
  29275   "RTN","VPR YFRP1",84, 0)
  29276    I VPRYWEE K,'$G(^XTM P("VPRYFRP ","STOP"))  D QWEEK(V PRYWEEK)
  29277   "RTN","VPR YFRP1",85, 0)
  29278    Q
  29279   "RTN","VPR YFRP1",86, 0)
  29280   SIZEPT(VPR YDFN) ; Ex tract data  for a pat ient and r eturn size
  29281   "RTN","VPR YFRP1",87, 0)
  29282    N VPRYSIZ E,VPRYDOM, VPRBATCH,V PRYET,DOMS IZE
  29283   "RTN","VPR YFRP1",88, 0)
  29284    S VPRYSIZ E=0,VPRBAT CH="VPRYFR P"
  29285   "RTN","VPR YFRP1",89, 0)
  29286    S VPRYDOM ="" F  S V PRYDOM=$O( VPRYDOMS(V PRYDOM)) Q :VPRYDOM=" "  D
  29287   "RTN","VPR YFRP1",90, 0)
  29288    . D CLEAN DOM
  29289   "RTN","VPR YFRP1",91, 0)
  29290    . S VPRYE T=$H
  29291   "RTN","VPR YFRP1",92, 0)
  29292    . S DOMSI ZE=$$SIZED OM(VPRYDFN ,VPRYDOM)
  29293   "RTN","VPR YFRP1",93, 0)
  29294    . S VPRYE T=$$HDIFF^ XLFDT($H,V PRYET,2)
  29295   "RTN","VPR YFRP1",94, 0)
  29296    . S VPRYS IZE=VPRYSI ZE+DOMSIZE
  29297   "RTN","VPR YFRP1",95, 0)
  29298    . D TOPSI ZE^VPRYFRP (VPRYDFN,V PRYDOM,VPR YET,"Extra ctTime")
  29299   "RTN","VPR YFRP1",96, 0)
  29300    . D TOPSI ZE^VPRYFRP (VPRYDFN,V PRYDOM,DOM SIZE,"Extr actSize")
  29301   "RTN","VPR YFRP1",97, 0)
  29302    Q VPRYSIZ E
  29303   "RTN","VPR YFRP1",98, 0)
  29304    ;
  29305   "RTN","VPR YFRP1",99, 0)
  29306   SIZEDOM(DF N,DOMAIN)  ; Extract  1 domain a nd return  size
  29307   "RTN","VPR YFRP1",100 ,0)
  29308    N $ESTACK ,$ETRAP S  $ETRAP="D  EXTERR^VPR YFRP"
  29309   "RTN","VPR YFRP1",101 ,0)
  29310    Q:$G(^XTM P("VPRYFRP ","STOP")) =1 0
  29311   "RTN","VPR YFRP1",102 ,0)
  29312    N FILTER, RSLT,SIZE
  29313   "RTN","VPR YFRP1",103 ,0)
  29314    S FILTER( "patientId ")=DFN
  29315   "RTN","VPR YFRP1",104 ,0)
  29316    S FILTER( "domain")= DOMAIN
  29317   "RTN","VPR YFRP1",105 ,0)
  29318    D GET^VPR DJ(.RSLT,. FILTER)
  29319   "RTN","VPR YFRP1",106 ,0)
  29320    S SIZE=$$ SIZEREF^VP RYFRP(RSLT )
  29321   "RTN","VPR YFRP1",107 ,0)
  29322    S ^XTMP(" VPRYFRP"," TASKS",VPR YWEEK,"cou nt")=$G(^X TMP("VPRYF RP","TASKS ",VPRYWEEK ,"count")) +1
  29323   "RTN","VPR YFRP1",108 ,0)
  29324    S ^XTMP(" VPRYFRP"," TASKS",VPR YWEEK,"res ult")=RSLT
  29325   "RTN","VPR YFRP1",109 ,0)
  29326    K @RSLT ; ^XTMP("VPR YFRP",VPRY DFN,VPRYDO M)
  29327   "RTN","VPR YFRP1",110 ,0)
  29328    Q SIZE
  29329   "RTN","VPR YFRP1",111 ,0)
  29330    ;
  29331   "RTN","VPR YFRP1",112 ,0)
  29332   CLEANDOM ;  Clean up  partition  for domain  extract
  29333   "RTN","VPR YFRP1",113 ,0)
  29334    N X
  29335   "RTN","VPR YFRP1",114 ,0)
  29336    K ^TMP("V PRY",$J)
  29337   "RTN","VPR YFRP1",115 ,0)
  29338    F X="VPRY WEEK","VPR YDOMS","VP RYDFN","VP RYDOM","VP RYSIZE","V PRYH","VPR BATCH","VP RFZTSK" M  ^TMP("VPRY ",$J,X)=@X
  29339   "RTN","VPR YFRP1",116 ,0)
  29340    D KILL^XU SCLEAN
  29341   "RTN","VPR YFRP1",117 ,0)
  29342    F X="VPRY WEEK","VPR YDOMS","VP RYDFN","VP RYDOM","VP RYSIZE","V PRYH","VPR BATCH","VP RFZTSK" M  @X=^TMP("V PRY",$J,X)
  29343   "RTN","VPR YFRP1",118 ,0)
  29344    K ^TMP("V PRY",$J)
  29345   "RTN","VPR YFRP1",119 ,0)
  29346    Q
  29347   "RTN","VPR YFRP1",120 ,0)
  29348    ; 
  29349   "RTN","VPR YFRP1",121 ,0)
  29350   SHOWCNT ;  Show count s of uniqu e patients  by week
  29351   "RTN","VPR YFRP1",122 ,0)
  29352    N WEEK
  29353   "RTN","VPR YFRP1",123 ,0)
  29354    S WEEK=0  F  S WEEK= $O(^XTMP(" VPRYFRP"," WEEK",WEEK )) Q:'WEEK   D
  29355   "RTN","VPR YFRP1",124 ,0)
  29356    . W !,"We ek beginni ng "_$$FMT E^XLFDT(WE EK,8)_":"
  29357   "RTN","VPR YFRP1",125 ,0)
  29358    . W ?26,$ J(^XTMP("V PRYFRP","W EEK",WEEK, "count"),7 )," patien ts"
  29359   "RTN","VPR YFRP1",126 ,0)
  29360    W !!,?10, "Total pat ients:",?2 6,$J(^XTMP ("VPRYFRP" ,"TOTALS", "patients" ),7)
  29361   "RTN","VPR YFRP1",127 ,0)
  29362    Q
  29363   "RTN","VPR YFRP1",128 ,0)
  29364   SHOWSIZE ;  Show extr act sizes  by week
  29365   "RTN","VPR YFRP1",129 ,0)
  29366    N NAME,WE EK,SIZE,DF N,SECS,TOT SIZE,TOTSE CS
  29367   "RTN","VPR YFRP1",130 ,0)
  29368    S TOTSIZE =0,TOTSECS =0
  29369   "RTN","VPR YFRP1",131 ,0)
  29370    S WEEK=0  F  S WEEK= $O(^XTMP(" VPRYFRP"," WEEK",WEEK )) Q:'WEEK   D
  29371   "RTN","VPR YFRP1",132 ,0)
  29372    . I $G(^X TMP("VPRYF RP","TASKS ",WEEK,"st atus"))'=" Finished"  QUIT
  29373   "RTN","VPR YFRP1",133 ,0)
  29374    . S SIZE= 0
  29375   "RTN","VPR YFRP1",134 ,0)
  29376    . S DFN=0  F  S DFN= $O(^XTMP(" VPRYFRP"," WEEK",WEEK ,DFN)) Q:' DFN  D
  29377   "RTN","VPR YFRP1",135 ,0)
  29378    . . S SIZ E=SIZE+^XT MP("VPRYFR P","WEEK", WEEK,DFN)
  29379   "RTN","VPR YFRP1",136 ,0)
  29380    . S SECS= $G(^XTMP(" VPRYFRP"," WEEK",WEEK ),0)
  29381   "RTN","VPR YFRP1",137 ,0)
  29382    . S TOTSI ZE=TOTSIZE +SIZE,TOTS ECS=TOTSEC S+SECS
  29383   "RTN","VPR YFRP1",138 ,0)
  29384    . W !,$$F MTE^XLFDT( WEEK),?15, $J(SIZE,15 )," bytes" ,?40,SECS\ 60," minut es ",SECS# 60," secon ds"
  29385   "RTN","VPR YFRP1",139 ,0)
  29386    W !!,"Tot als:",?15, $J(TOTSIZE ,15)," byt es",?40,TO TSECS\60,"  minutes " ,TOTSECS#6 0," second s"
  29387   "RTN","VPR YFRP1",140 ,0)
  29388    Q
  29389   "RTN","VPR YFRP1",141 ,0)
  29390   SHOWSTS ;  Show task  status and  errors
  29391   "RTN","VPR YFRP1",142 ,0)
  29392    G SHOWSTS ^VPRYFRP
  29393   "RTN","VPR YFRP1",143 ,0)
  29394    ;
  29395   "RTN","VPR YFRP1",144 ,0)
  29396   SHOWTOP ;  Show large st sizes a nd times
  29397   "RTN","VPR YFRP1",145 ,0)
  29398    G SHOWTOP ^VPRYFRP
  29399   "RTN","VPR YFRP1",146 ,0)
  29400    ;
  29401   "RTN","VPR YFRP1",147 ,0)
  29402    ;
  29403   "RTN","VPR YFRP1",148 ,0)
  29404   PRMTWKS(BE G,END) ; p rompt for  date range  of weeks
  29405   "RTN","VPR YFRP1",149 ,0)
  29406    S BEG="", END=""
  29407   "RTN","VPR YFRP1",150 ,0)
  29408    S BEG=$$A SKDT("Begi nning Date ","Enter b eginning v isit date  to evaluat e.") Q:'BE G
  29409   "RTN","VPR YFRP1",151 ,0)
  29410    S END=$$A SKDT("Endi ng Date"," Enter late st date to  evaluate. ") Q:'END
  29411   "RTN","VPR YFRP1",152 ,0)
  29412    S BEG=$$F MADD^XLFDT (BEG,-$$DO W^XLFDT(BE G,1))    ;  get previ ous Sunday
  29413   "RTN","VPR YFRP1",153 ,0)
  29414    S END=$$F MADD^XLFDT (END,(6-$$ DOW^XLFDT( END,1))) ;  get follo wing Satur day
  29415   "RTN","VPR YFRP1",154 ,0)
  29416    S BEG=$P( BEG,"."),E ND=$P(END, ".")                ;  only date s
  29417   "RTN","VPR YFRP1",155 ,0)
  29418    I BEG>END  N X S X=B EG,BEG=END ,END=X              ;  swap if e ntered bac kwards
  29419   "RTN","VPR YFRP1",156 ,0)
  29420    W !,"Sear ching visi ts from Su nday ",$$F MTE^XLFDT( BEG)
  29421   "RTN","VPR YFRP1",157 ,0)
  29422    W !,"             th rough Satu rday ",$$F MTE^XLFDT( END)
  29423   "RTN","VPR YFRP1",158 ,0)
  29424    I '$$ASKY N("Continu e","No") S  BEG="",EN D=""
  29425   "RTN","VPR YFRP1",159 ,0)
  29426    Q
  29427   "RTN","VPR YFRP1",160 ,0)
  29428   ASKDT(ASK, HELP) ; pr ompt for a  date in t he past
  29429   "RTN","VPR YFRP1",161 ,0)
  29430    N DIR,DTO UT,DUOUT,D IRUT,DIROU T,Y
  29431   "RTN","VPR YFRP1",162 ,0)
  29432    S DIR(0)= "D^::EP",D IR("A")=AS K,DIR("?") =HELP
  29433   "RTN","VPR YFRP1",163 ,0)
  29434    D ^DIR I  $D(DIRUT)  Q ""
  29435   "RTN","VPR YFRP1",164 ,0)
  29436    Q Y
  29437   "RTN","VPR YFRP1",165 ,0)
  29438    ;
  29439   "RTN","VPR YFRP1",166 ,0)
  29440   ASKYN(ASK, DFLT) ; pr ompt for y es/no
  29441   "RTN","VPR YFRP1",167 ,0)
  29442    N DIR,DTO UT,DUOUT,D IRUT,DIROU T,Y
  29443   "RTN","VPR YFRP1",168 ,0)
  29444    S DIR(0)= "Y",DIR("A ")=ASK,DIR ("B")=DFLT
  29445   "RTN","VPR YFRP1",169 ,0)
  29446    D ^DIR
  29447   "RTN","VPR YFRP1",170 ,0)
  29448    Q Y
  29449   "RTN","VPR YFRP1",171 ,0)
  29450    ;
  29451   "RTN","VPR YPAR")
  29452   0^67^B3971 880
  29453   "RTN","VPR YPAR",1,0)
  29454   VPRYPAR ;S LC/KCM --  Modify Par ameters
  29455   "RTN","VPR YPAR",2,0)
  29456    ;;1.0;VIR TUAL PATIE NT RECORD; **3**;Sep  01, 2011;B uild 283
  29457   "RTN","VPR YPAR",3,0)
  29458    ;
  29459   "RTN","VPR YPAR",4,0)
  29460   PARLOOP ;  Loop thru  parameter
  29461   "RTN","VPR YPAR",5,0)
  29462    N PAR,ENT ,INST,IEN
  29463   "RTN","VPR YPAR",6,0)
  29464    S PAR=$O( ^XTV(8989. 51,"B","VP R PARAMETE RS",0))
  29465   "RTN","VPR YPAR",7,0)
  29466    S ENT=""  F  S ENT=$ O(^XTV(898 9.5,"AC",P AR,ENT)) Q :ENT=""  D
  29467   "RTN","VPR YPAR",8,0)
  29468    . S INST= "" F  S IN ST=$O(^XTV (8989.5,"A C",PAR,ENT ,INST)) Q: INST=""  D
  29469   "RTN","VPR YPAR",9,0)
  29470    . . S IEN =0 F  S IE N=$O(^XTV( 8989.5,"AC ",PAR,ENT, INST,IEN))  Q:IEN=""   D
  29471   "RTN","VPR YPAR",10,0 )
  29472    . . . I $ P(^XTV(898 9.5,IEN,0) ,":",6)'=" VPR USER P REF" Q
  29473   "RTN","VPR YPAR",11,0 )
  29474    . . . D P ULLPID(IEN )
  29475   "RTN","VPR YPAR",12,0 )
  29476    Q
  29477   "RTN","VPR YPAR",13,0 )
  29478   PULLPID(IE N) ; Remov e PID entr ies
  29479   "RTN","VPR YPAR",14,0 )
  29480    N JSON,WP ,OBJ,ERR,I
  29481   "RTN","VPR YPAR",15,0 )
  29482    S I=0 F   S I=$O(^XT V(8989.5,I EN,2,I)) Q :'I  S JSO N(I)=^XTV( 8989.5,IEN ,2,I,0)
  29483   "RTN","VPR YPAR",16,0 )
  29484    D DECODE^ VPRJSON("J SON","OBJ" ,"ERR")
  29485   "RTN","VPR YPAR",17,0 )
  29486    I $D(ERR)  W !,"Erro r decoding  ",IEN Q
  29487   "RTN","VPR YPAR",18,0 )
  29488    I '$D(OBJ ("cpe.cont ext.patien t")) Q
  29489   "RTN","VPR YPAR",19,0 )
  29490    ;
  29491   "RTN","VPR YPAR",20,0 )
  29492    K OBJ("cp e.context. patient"), JSON
  29493   "RTN","VPR YPAR",21,0 )
  29494    D ENCODE^ VPRJSON("O BJ","JSON" ,"ERR")
  29495   "RTN","VPR YPAR",22,0 )
  29496    I $D(ERR)  W !,"Erro r encoding  ",IEN
  29497   "RTN","VPR YPAR",23,0 )
  29498    ;
  29499   "RTN","VPR YPAR",24,0 )
  29500    W !,"Upda ting ",^XT V(8989.5,I EN,0)
  29501   "RTN","VPR YPAR",25,0 )
  29502    S I=0 F   S I=$O(JSO N(I)) Q:'I   S WP(I,0 )=JSON(I)
  29503   "RTN","VPR YPAR",26,0 )
  29504    I $D(WP)  D WP^DIE(8 989.5,IEN_ ",",2,""," WP","ERR")
  29505   "RTN","VPR YPAR",27,0 )
  29506    I $D(DIER R) W !,"Sa ve failed  for WP: ", IEN,!
  29507   "RTN","VPR YPAR",28,0 )
  29508    D CLEAN^D ILF
  29509   "RTN","VPR YPAR",29,0 )
  29510    Q
  29511   "RTN","VPR YPAR",30,0 )
  29512   SHOWPAR ;  Show value s for para meters
  29513   "RTN","VPR YPAR",31,0 )
  29514    N PARAM,I EN
  29515   "RTN","VPR YPAR",32,0 )
  29516    S PARAM=$ O(^XTV(898 9.51,"B"," VPR PARAME TERS",0))
  29517   "RTN","VPR YPAR",33,0 )
  29518    W !,"Para m:",PARAM
  29519   "RTN","VPR YPAR",34,0 )
  29520    S IEN=0 F   S IEN=$O (^XTV(8989 .5,IEN)) Q :'IEN  D
  29521   "RTN","VPR YPAR",35,0 )
  29522    . I $P(^X TV(8989.5, IEN,0),"^" ,2)'=PARAM  Q
  29523   "RTN","VPR YPAR",36,0 )
  29524    . S INST= $P(^XTV(89 89.5,IEN,0 ),"^",3)
  29525   "RTN","VPR YPAR",37,0 )
  29526    . I $P(IN ST,":",6)' ="VPR USER  PREF" Q
  29527   "RTN","VPR YPAR",38,0 )
  29528    . N JSON, OBJ,ERR,X
  29529   "RTN","VPR YPAR",39,0 )
  29530    . S I=0 F   S I=$O(^ XTV(8989.5 ,IEN,2,I))  Q:'I  S J SON(I)=^XT V(8989.5,I EN,2,I,0)
  29531   "RTN","VPR YPAR",40,0 )
  29532    . D DECOD E^VPRJSON( "JSON","OB J","ERR")
  29533   "RTN","VPR YPAR",41,0 )
  29534    . W !!,IN ST,"  ("_I EN_") ---- ---------- ------"
  29535   "RTN","VPR YPAR",42,0 )
  29536    . S X=""  F  S X=$O( OBJ(X)) Q: X=""  W !, X," = ",OB J(X)
  29537   "RTN","VPR YPAR",43,0 )
  29538    Q
  29539   "SEC","^DI C",560,560 ,0,"AUDIT" )
  29540   @
  29541   "SEC","^DI C",560,560 ,0,"DD")
  29542   @
  29543   "SEC","^DI C",560,560 ,0,"DEL")
  29544   @
  29545   "SEC","^DI C",560,560 ,0,"LAYGO" )
  29546   @
  29547   "SEC","^DI C",560,560 ,0,"RD")
  29548   @
  29549   "SEC","^DI C",560,560 ,0,"WR")
  29550   @
  29551   "SEC","^DI C",560.1,5 60.1,0,"AU DIT")
  29552   @
  29553   "SEC","^DI C",560.1,5 60.1,0,"DD ")
  29554   @
  29555   "SEC","^DI C",560.1,5 60.1,0,"DE L")
  29556   @
  29557   "SEC","^DI C",560.1,5 60.1,0,"LA YGO")
  29558   @
  29559   "SEC","^DI C",560.1,5 60.1,0,"RD ")
  29560   @
  29561   "SEC","^DI C",560.1,5 60.1,0,"WR ")
  29562   @
  29563   "SEC","^DI C",560.11, 560.11,0," AUDIT")
  29564   @
  29565   "SEC","^DI C",560.11, 560.11,0," DD")
  29566   @
  29567   "SEC","^DI C",560.11, 560.11,0," DEL")
  29568   @
  29569   "SEC","^DI C",560.11, 560.11,0," LAYGO")
  29570   @
  29571   "SEC","^DI C",560.11, 560.11,0," RD")
  29572   @
  29573   "SEC","^DI C",560.11, 560.11,0," WR")
  29574   @
  29575   "SEC","^DI C",561,561 ,0,"AUDIT" )
  29576   @
  29577   "SEC","^DI C",561,561 ,0,"DD")
  29578   @
  29579   "SEC","^DI C",561,561 ,0,"DEL")
  29580   @
  29581   "SEC","^DI C",561,561 ,0,"LAYGO" )
  29582   #
  29583   "SEC","^DI C",561,561 ,0,"RD")
  29584   #
  29585   "SEC","^DI C",561,561 ,0,"WR")
  29586   #
  29587   "SEC","^DI C",561.2,5 61.2,0,"AU DIT")
  29588   @
  29589   "SEC","^DI C",561.2,5 61.2,0,"DD ")
  29590   @
  29591   "SEC","^DI C",561.2,5 61.2,0,"DE L")
  29592   @
  29593   "SEC","^DI C",561.2,5 61.2,0,"LA YGO")
  29594   @
  29595   "SEC","^DI C",561.2,5 61.2,0,"RD ")
  29596   @
  29597   "SEC","^DI C",561.2,5 61.2,0,"WR ")
  29598   @
  29599   "VER")
  29600   8.0^22.0
  29601   "^DD",100. 98,100.98, 0)
  29602   FIELD^^4^5
  29603   "^DD",100. 98,100.98, 0,"DDA")
  29604   N
  29605   "^DD",100. 98,100.98, 0,"DT")
  29606   2960814
  29607   "^DD",100. 98,100.98, 0,"IX","AD ",100.981, .01)
  29608  
  29609   "^DD",100. 98,100.98, 0,"IX","B" ,100.98,.0 1)
  29610  
  29611   "^DD",100. 98,100.98, 0,"IX","B" ,100.98,3)
  29612  
  29613   "^DD",100. 98,100.98, 0,"NM","DI SPLAY GROU P")
  29614  
  29615   "^DD",100. 98,100.98, 0,"PT",100 ,23)
  29616  
  29617   "^DD",100. 98,100.98, 0,"PT",100 .65,.01)
  29618  
  29619   "^DD",100. 98,100.98, 0,"PT",100 .981,.01)
  29620  
  29621   "^DD",100. 98,100.98, 0,"PT",100 .995,1.1)
  29622  
  29623   "^DD",100. 98,100.98, 0,"PT",101 .41,5)
  29624  
  29625   "^DD",100. 98,100.98, 0,"PT",101 .43,5)
  29626  
  29627   "^DD",100. 98,100.98, 0,"PT",123 .5,123.01)
  29628  
  29629   "^DD",100. 98,100.98, 0,"VRPK")
  29630   ORDER ENTR Y/RESULTS  REPORTING
  29631   "^DD",100. 98,100.98, .01,0)
  29632   NAME^RF^^0 ;1^K:X[""" "!($A(X)=4 5) X I $D( X) K:$L(X) >30!($L(X) <3)!'(X'?1 P.E) X
  29633   "^DD",100. 98,100.98, .01,1,0)
  29634   ^.1^^-1
  29635   "^DD",100. 98,100.98, .01,1,1,0)
  29636   100.98^B
  29637   "^DD",100. 98,100.98, .01,1,1,1)
  29638   S ^ORD(100 .98,"B",$E (X,1,30),D A)=""
  29639   "^DD",100. 98,100.98, .01,1,1,2)
  29640   K ^ORD(100 .98,"B",$E (X,1,30),D A)
  29641   "^DD",100. 98,100.98, .01,3)
  29642   ANSWER MUS T BE 3-30  CHARACTERS  IN LENGTH
  29643   "^DD",100. 98,100.98, .01,4)
  29644  
  29645   "^DD",100. 98,100.98, .01,21,0)
  29646   ^^3^3^2920 224^^^^
  29647   "^DD",100. 98,100.98, .01,21,1,0 )
  29648   This is th e name of  the displa y group fo r a partic ular kind  of order.
  29649   "^DD",100. 98,100.98, .01,21,2,0 )
  29650   The displa y group ge nerally co rresponds  to a hospi tal servic e or part
  29651   "^DD",100. 98,100.98, .01,21,3,0 )
  29652   of a servi ce.
  29653   "^DD",100. 98,100.98, .01,"DT")
  29654   2890131
  29655   "^DD",100. 98,100.98, 1,0)
  29656   MEMBER^100 .981P^^1;0
  29657   "^DD",100. 98,100.98, 1,3)
  29658   Enter a di splay grou p as a mem ber.
  29659   "^DD",100. 98,100.98, 1,21,0)
  29660   ^^3^3^2920 224^^^^
  29661   "^DD",100. 98,100.98, 1,21,1,0)
  29662   This is a  list of sp ecific dis play group s that `be long' to t he display
  29663   "^DD",100. 98,100.98, 1,21,2,0)
  29664   group list ed in the  NAME field .  (This i s similar  to menu it ems in the
  29665   "^DD",100. 98,100.98, 1,21,3,0)
  29666   OPTION Fil e.)
  29667   "^DD",100. 98,100.98, 2,0)
  29668   MIXED NAME ^F^^0;2^K: $L(X)>30!( $L(X)<1) X
  29669   "^DD",100. 98,100.98, 2,3)
  29670   Answer mus t be 1-30  characters  in length .
  29671   "^DD",100. 98,100.98, 2,21,0)
  29672   ^^3^3^2960 617^
  29673   "^DD",100. 98,100.98, 2,21,1,0)
  29674   This field  contains  a mixed ca se name fo r the disp lay group.   The name  
  29675   "^DD",100. 98,100.98, 2,21,2,0)
  29676   should be  as short a s possible  without b eing obscu re.  This  name is 
  29677   "^DD",100. 98,100.98, 2,21,3,0)
  29678   primarily  intended f or use in  the window s display  of orders.
  29679   "^DD",100. 98,100.98, 2,"DT")
  29680   2960617
  29681   "^DD",100. 98,100.98, 3,0)
  29682   SHORT NAME ^F^^0;3^K: X[""""!($A (X)=45) X  I $D(X) K: $L(X)>5!($ L(X)<1) X
  29683   "^DD",100. 98,100.98, 3,1,0)
  29684   ^.1
  29685   "^DD",100. 98,100.98, 3,1,1,0)
  29686   100.98^B^M NEMONIC
  29687   "^DD",100. 98,100.98, 3,1,1,1)
  29688   S:'$D(^ORD (100.98,"B ",$E(X,1,3 0),DA)) ^( DA)=1
  29689   "^DD",100. 98,100.98, 3,1,1,2)
  29690   I $D(^ORD( 100.98,"B" ,$E(X,1,30 ),DA)),^(D A) K ^(DA)
  29691   "^DD",100. 98,100.98, 3,3)
  29692   ANSWER MUS T BE 1-5 C HARACTERS  IN LENGTH
  29693   "^DD",100. 98,100.98, 3,21,0)
  29694   ^^2^2^2920 224^^^
  29695   "^DD",100. 98,100.98, 3,21,1,0)
  29696   This is an  abbreviat ion for th e display  group to b e used in  displays a nd
  29697   "^DD",100. 98,100.98, 3,21,2,0)
  29698   reports.
  29699   "^DD",100. 98,100.98, 3,"DT")
  29700   2880308
  29701   "^DD",100. 98,100.98, 4,0)
  29702   DEFAULT DI ALOG^P101. 41'^ORD(10 1.41,^0;4^ Q
  29703   "^DD",100. 98,100.98, 4,3)
  29704   Enter the  default or dering dia log for th is display  group.
  29705   "^DD",100. 98,100.98, 4,21,0)
  29706   ^^2^2^2960 815^^
  29707   "^DD",100. 98,100.98, 4,21,1,0)
  29708   This is th e dialog t hat will b e used as  the defaul t definiti on when
  29709   "^DD",100. 98,100.98, 4,21,2,0)
  29710   placing qu ick orders  associate d with thi s display  group.
  29711   "^DD",100. 98,100.98, 4,"DT")
  29712   2960814
  29713   "^DD",100. 98,100.981 ,0)
  29714   MEMBER SUB -FIELD^^.0 1^2
  29715   "^DD",100. 98,100.981 ,0,"DT")
  29716   2920601
  29717   "^DD",100. 98,100.981 ,0,"IX","B ",100.981, .01)
  29718  
  29719   "^DD",100. 98,100.981 ,0,"NM","M EMBER")
  29720  
  29721   "^DD",100. 98,100.981 ,0,"UP")
  29722   100.98
  29723   "^DD",100. 98,100.981 ,.001,0)
  29724   SEQUENCE^N J5,1^^ ^K: +X'=X!(X>9 00)!(X<0)! (X?.E1"."2 N.N) X
  29725   "^DD",100. 98,100.981 ,.001,3)
  29726   Type a Num ber betwee n 0 and 90 0, 1 Decim al Digit
  29727   "^DD",100. 98,100.981 ,.001,21,0 )
  29728   ^^2^2^2920 601^
  29729   "^DD",100. 98,100.981 ,.001,21,1 ,0)
  29730   This is th e sequence  of the me mber in th e display  group for  reporting
  29731   "^DD",100. 98,100.981 ,.001,21,2 ,0)
  29732   purposes.
  29733   "^DD",100. 98,100.981 ,.001,"DT" )
  29734   2920601
  29735   "^DD",100. 98,100.981 ,.01,0)
  29736   MEMBER^MP1 00.98X^ORD (100.98,^0 ;1^S ORDDF =100.98 D  TREE^ORDD1 01
  29737   "^DD",100. 98,100.981 ,.01,1,0)
  29738   ^.1
  29739   "^DD",100. 98,100.981 ,.01,1,1,0 )
  29740   100.981^B
  29741   "^DD",100. 98,100.981 ,.01,1,1,1 )
  29742   S ^ORD(100 .98,DA(1), 1,"B",$E(X ,1,30),DA) =""
  29743   "^DD",100. 98,100.981 ,.01,1,1,2 )
  29744   K ^ORD(100 .98,DA(1), 1,"B",$E(X ,1,30),DA)
  29745   "^DD",100. 98,100.981 ,.01,1,2,0 )
  29746   100.98^AD^ MUMPS
  29747   "^DD",100. 98,100.981 ,.01,1,2,1 )
  29748   S ^ORD(100 .98,"AD",$ E(X,1,30), DA(1),DA)= ""
  29749   "^DD",100. 98,100.981 ,.01,1,2,2 )
  29750   K ^ORD(100 .98,"AD",$ E(X,1,30), DA(1),DA)
  29751   "^DD",100. 98,100.981 ,.01,1,2," %D",0)
  29752   ^^2^2^2971 217^^
  29753   "^DD",100. 98,100.981 ,.01,1,2," %D",1,0)
  29754   ^ORD(100.9 8,"AD",ORM EM,ORGRP,D A)
  29755   "^DD",100. 98,100.981 ,.01,1,2," %D",2,0)
  29756   Provides b ackwards p ointer fro m member t o parent g roup.
  29757   "^DD",100. 98,100.981 ,.01,3)
  29758   Enter a di splay grou p.  A disp lay group  that is an  ancestor  may not al so be a me mber.
  29759   "^DD",100. 98,100.981 ,.01,4)
  29760  
  29761   "^DD",100. 98,100.981 ,.01,21,0)
  29762   ^^2^2^2920 224^^^
  29763   "^DD",100. 98,100.981 ,.01,21,1, 0)
  29764   This is a  display gr oup listed  in the NA ME field.  (This is s imilar to  a
  29765   "^DD",100. 98,100.981 ,.01,21,2, 0)
  29766   menu item  in the OPT ION File.)
  29767   "^DD",100. 98,100.981 ,.01,"DT")
  29768   2890207
  29769   "^DD",101. 41,101.41, 0)
  29770   FIELD^^99^ 30
  29771   "^DD",101. 41,101.41, 0,"DDA")
  29772   N
  29773   "^DD",101. 41,101.41, 0,"DT")
  29774   2980501
  29775   "^DD",101. 41,101.41, 0,"IX","AB ",101.41,. 01)
  29776  
  29777   "^DD",101. 41,101.41, 0,"IX","AD ",101.412, 2)
  29778  
  29779   "^DD",101. 41,101.41, 0,"IX","AM ",101.41,9 9)
  29780  
  29781   "^DD",101. 41,101.41, 0,"IX","AM 2",101.41, 2)
  29782  
  29783   "^DD",101. 41,101.41, 0,"IX","AM 51",101.41 ,51)
  29784  
  29785   "^DD",101. 41,101.41, 0,"IX","AM 52",101.41 ,52)
  29786  
  29787   "^DD",101. 41,101.41, 0,"IX","AM M",101.412 ,.01)
  29788  
  29789   "^DD",101. 41,101.41, 0,"IX","AM M2",101.41 2,2)
  29790  
  29791   "^DD",101. 41,101.41, 0,"IX","AM M3",101.41 2,3)
  29792  
  29793   "^DD",101. 41,101.41, 0,"IX","AM M4",101.41 2,4)
  29794  
  29795   "^DD",101. 41,101.41, 0,"IX","AM M5",101.41 2,5)
  29796  
  29797   "^DD",101. 41,101.41, 0,"IX","AP KG",101.41 ,7)
  29798  
  29799   "^DD",101. 41,101.41, 0,"IX","C" ,101.41,2)
  29800  
  29801   "^DD",101. 41,101.41, 0,"NM","OR DER DIALOG ")
  29802  
  29803   "^DD",101. 41,101.41, 0,"PT",100 ,2)
  29804  
  29805   "^DD",101. 41,101.41, 0,"PT",100 ,7)
  29806  
  29807   "^DD",101. 41,101.41, 0,"PT",100 .045,.02)
  29808  
  29809   "^DD",101. 41,101.41, 0,"PT",100 .5,4)
  29810  
  29811   "^DD",101. 41,101.41, 0,"PT",100 .5,5)
  29812  
  29813   "^DD",101. 41,101.41, 0,"PT",100 .98,4)
  29814  
  29815   "^DD",101. 41,101.41, 0,"PT",101 .412,1)
  29816  
  29817   "^DD",101. 41,101.41, 0,"PT",101 .412,2)
  29818  
  29819   "^DD",101. 41,101.41, 0,"PT",101 .415,2)
  29820  
  29821   "^DD",101. 41,101.41, 0,"PT",101 .416,.02)
  29822  
  29823   "^DD",101. 41,101.41, 0,"PT",101 .441,.01)
  29824  
  29825   "^DD",101. 41,101.41, 0,"PT",561 .05,.01)
  29826  
  29827   "^DD",101. 41,101.41, 0,"PT",801 .41,15)
  29828  
  29829   "^DD",101. 41,101.41, 0,"PT",801 .4118,.01)
  29830  
  29831   "^DD",101. 41,101.41, 0,"VRPK")
  29832   OR
  29833   "^DD",101. 41,101.41, .01,0)
  29834   NAME^RF^^0 ;1^K:X[""" "!($A(X)=4 5) X I $D( X) K:$L(X) >63!($L(X) <3)!'(X'?1 P.E) X
  29835   "^DD",101. 41,101.41, .01,1,0)
  29836   ^.1^^-1
  29837   "^DD",101. 41,101.41, .01,1,2,0)
  29838   101.41^AB
  29839   "^DD",101. 41,101.41, .01,1,2,1)
  29840   S ^ORD(101 .41,"AB",$ E(X,1,63), DA)=""
  29841   "^DD",101. 41,101.41, .01,1,2,2)
  29842   K ^ORD(101 .41,"AB",$ E(X,1,63), DA)
  29843   "^DD",101. 41,101.41, .01,1,2,"% D",0)
  29844   ^^1^1^2971 020^
  29845   "^DD",101. 41,101.41, .01,1,2,"% D",1,0)
  29846   This is a  regular in dex on the  full 63 c haracters  of the Nam e field.
  29847   "^DD",101. 41,101.41, .01,1,2,"D T")
  29848   2971020
  29849   "^DD",101. 41,101.41, .01,3)
  29850   Answer mus t be 3-63  characters  in length .
  29851   "^DD",101. 41,101.41, .01,21,0)
  29852   ^^3^3^2971 219^
  29853   "^DD",101. 41,101.41, .01,21,1,0 )
  29854   This is th e name of  the dialog ; entries  that were  converted  from the
  29855   "^DD",101. 41,101.41, .01,21,2,0 )
  29856   Protocol f ile will r etain the  same name.   Namespac ing is not  required,
  29857   "^DD",101. 41,101.41, .01,21,3,0 )
  29858   but still  encouraged .
  29859   "^DD",101. 41,101.41, .01,"DT")
  29860   2971020
  29861   "^DD",101. 41,101.41, 2,0)
  29862   DISPLAY TE XT^FX^^0;2 ^K:$L(X)>8 0!($L(X)<3 )!($$CHKNA M^ORUTL(X) ) X
  29863   "^DD",101. 41,101.41, 2,1,0)
  29864   ^.1
  29865   "^DD",101. 41,101.41, 2,1,1,0)
  29866   101.41^C
  29867   "^DD",101. 41,101.41, 2,1,1,1)
  29868   S ^ORD(101 .41,"C",$$ UP^XLFSTR( $E(X,1,63) ),DA)=""
  29869   "^DD",101. 41,101.41, 2,1,1,2)
  29870   K ^ORD(101 .41,"C",$$ UP^XLFSTR( $E(X,1,63) ),DA)
  29871   "^DD",101. 41,101.41, 2,1,1,"DT" )
  29872   2950112
  29873   "^DD",101. 41,101.41, 2,1,2,0)
  29874   101.41^AM2 ^MUMPS
  29875   "^DD",101. 41,101.41, 2,1,2,1)
  29876   D REDOM^OR DD41
  29877   "^DD",101. 41,101.41, 2,1,2,2)
  29878   D REDOM^OR DD41
  29879   "^DD",101. 41,101.41, 2,1,2,"%D" ,0)
  29880   ^^1^1^2990 210^
  29881   "^DD",101. 41,101.41, 2,1,2,"%D" ,1,0)
  29882   Update TIM ESTAMP whe never DISP LAY TEXT i s changed.
  29883   "^DD",101. 41,101.41, 2,1,2,"DT" )
  29884   2990210
  29885   "^DD",101. 41,101.41, 2,3)
  29886   Answer mus t be 3-80  characters  in length  and canno t contain  a semicolo n (;), a c omma (,),  an up-arro w (^), a d ash (-), o r an equal  sign (=).  
  29887   "^DD",101. 41,101.41, 2,21,0)
  29888   ^.001^1^1^ 3010913^^^ ^
  29889   "^DD",101. 41,101.41, 2,21,1,0)
  29890   The text o f this dia log's name  as it app ears on a  menu or su bheader.
  29891   "^DD",101. 41,101.41, 2,"DT")
  29892   3000823
  29893   "^DD",101. 41,101.41, 3,0)
  29894   DISABLE^F^ ^0;3^K:$L( X)>40!($L( X)<1) X
  29895   "^DD",101. 41,101.41, 3,3)
  29896   Enter a me ssage here  to disabl e this dia log, 1-40  characters  in length .
  29897   "^DD",101. 41,101.41, 3,21,0)
  29898   ^^3^3^2950 112^
  29899   "^DD",101. 41,101.41, 3,21,1,0)
  29900   This field  disables  use of thi s dialog w hen it con tains text .  The tex t
  29901   "^DD",101. 41,101.41, 3,21,2,0)
  29902   should be  a short me ssage expl aining why  use of th is dialog  has been
  29903   "^DD",101. 41,101.41, 3,21,3,0)
  29904   disabled,  as it will  be displa yed if thi s dialog i s selected .
  29905   "^DD",101. 41,101.41, 3,"DT")
  29906   2950112
  29907   "^DD",101. 41,101.41, 4,0)
  29908   TYPE^RS^P: prompt;D:d ialog;Q:qu ick order; O:order se t;M:menu;A :action;^0 ;4^Q
  29909   "^DD",101. 41,101.41, 4,3)
  29910   Specify a  type for t his dialog .
  29911   "^DD",101. 41,101.41, 4,21,0)
  29912   ^^5^5^2950 716^^^^
  29913   "^DD",101. 41,101.41, 4,21,1,0)
  29914   This field  defines t he type of  order dia log to be  processed.   Control
  29915   "^DD",101. 41,101.41, 4,21,2,0)
  29916   will be pa ssed to th e OE/RR Di alog Proce ssor for d ialog item s; menu ty pes
  29917   "^DD",101. 41,101.41, 4,21,3,0)
  29918   are used f or display ing and se lecting di alog items .  Action  types will  only
  29919   "^DD",101. 41,101.41, 4,21,4,0)
  29920   execute th e entry an d exit act ions, igno ring any i tems that  may exist;  these
  29921   "^DD",101. 41,101.41, 4,21,5,0)
  29922   dialogs sh ould not c reate entr ies in the  Orders fi le.
  29923   "^DD",101. 41,101.41, 4,"DT")
  29924   2950716
  29925   "^DD",101. 41,101.41, 5,0)
  29926   DISPLAY GR OUP^P100.9 8'^ORD(100 .98,^0;5^Q
  29927   "^DD",101. 41,101.41, 5,3)
  29928   Enter the  display gr oup contai ning order able items  defined b y this dia log.
  29929   "^DD",101. 41,101.41, 5,21,0)
  29930   ^^3^3^2950 112^
  29931   "^DD",101. 41,101.41, 5,21,1,0)
  29932   This field  determine s what dis play group  this dial og has bee n defined  for.
  29933   "^DD",101. 41,101.41, 5,21,2,0)
  29934   It will de fine which  orderable  items are  selectabl e with thi s dialog,
  29935   "^DD",101. 41,101.41, 5,21,3,0)
  29936   as well as  what serv ice to sen d the orde r to when  it is comp lete.
  29937   "^DD",101. 41,101.41, 5,"DT")
  29938   2950112
  29939   "^DD",101. 41,101.41, 6,0)
  29940   SIGNATURE  REQUIRED^S ^0:NONE;1: ORELSE;2:O RES;^0;6^Q
  29941   "^DD",101. 41,101.41, 6,3)
  29942   Enter the  OR key req uired to s ign orders  created b y this dia log
  29943   "^DD",101. 41,101.41, 6,21,0)
  29944   ^^6^6^2970 318^^
  29945   "^DD",101. 41,101.41, 6,21,1,0)
  29946   This field  indicates  what sign ature will  be requir ed for ord ers create d by
  29947   "^DD",101. 41,101.41, 6,21,2,0)
  29948   this dialo g, to be c onsidered  complete a nd ready t o release  to the ser vice
  29949   "^DD",101. 41,101.41, 6,21,3,0)
  29950   for action .  If this  flag is s et to NO a nd the dia log contai ns a promp t
  29951   "^DD",101. 41,101.41, 6,21,4,0)
  29952   for item(s ) from the  Orderable  Item file , the orde r created  may still
  29953   "^DD",101. 41,101.41, 6,21,5,0)
  29954   require a  signature  if any of  the items  ordered ar e individu ally flagg ed
  29955   "^DD",101. 41,101.41, 6,21,6,0)
  29956   as requiri ng a signa ture.
  29957   "^DD",101. 41,101.41, 6,"DT")
  29958   2970318
  29959   "^DD",101. 41,101.41, 7,0)
  29960   PACKAGE^P9 .4'^DIC(9. 4,^0;7^Q
  29961   "^DD",101. 41,101.41, 7,1,0)
  29962   ^.1
  29963   "^DD",101. 41,101.41, 7,1,1,0)
  29964   101.41^APK G
  29965   "^DD",101. 41,101.41, 7,1,1,1)
  29966   S ^ORD(101 .41,"APKG" ,$E(X,1,30 ),DA)=""
  29967   "^DD",101. 41,101.41, 7,1,1,2)
  29968   K ^ORD(101 .41,"APKG" ,$E(X,1,30 ),DA)
  29969   "^DD",101. 41,101.41, 7,1,1,"DT" )
  29970   2970325
  29971   "^DD",101. 41,101.41, 7,3)
  29972   Enter the  VISTA pack age that i s to recei ve orders  created by  this dial og.
  29973   "^DD",101. 41,101.41, 7,21,0)
  29974   ^^3^3^2950 208^
  29975   "^DD",101. 41,101.41, 7,21,1,0)
  29976   This is th e VISTA pa ckage that  is intend ed to rece ive orders  created b y
  29977   "^DD",101. 41,101.41, 7,21,2,0)
  29978   this dialo g; this is  required  for creati ng the HL7  messages  to pass th e
  29979   "^DD",101. 41,101.41, 7,21,3,0)
  29980   order.
  29981   "^DD",101. 41,101.41, 7,"DT")
  29982   2970325
  29983   "^DD",101. 41,101.41, 8,0)
  29984   VERIFY ORD ER^S^1:YES ;0:NO;^0;8 ^Q
  29985   "^DD",101. 41,101.41, 8,3)
  29986   Enter YES  to have or ders creat ed by this  dialog pr esented to  the user  before sav ing, with  the opport unity to e dit.
  29987   "^DD",101. 41,101.41, 8,21,0)
  29988   ^^3^3^2950 623^
  29989   "^DD",101. 41,101.41, 8,21,1,0)
  29990   This field  is a flag , which de termines i f the orde r created  by this di alog
  29991   "^DD",101. 41,101.41, 8,21,2,0)
  29992   will be pr esented to  the user  for verifi cation bef ore saving  in the Or ders
  29993   "^DD",101. 41,101.41, 8,21,3,0)
  29994   file; for  most quick  orders, t his flag s hould be s et to 0 (n o).
  29995   "^DD",101. 41,101.41, 8,"DT")
  29996   2950623
  29997   "^DD",101. 41,101.41, 9,0)
  29998   ASK FOR AN OTHER ORDE R^S^0:NO;1 :YES;2:YES -DON'T ASK ;^0;9^Q
  29999   "^DD",101. 41,101.41, 9,3)
  30000   Enter YES  to have th e user ask ed to ente r another  order from  this dial og before  exiting.
  30001   "^DD",101. 41,101.41, 9,21,0)
  30002   ^^6^6^2970 616^^^
  30003   "^DD",101. 41,101.41, 9,21,1,0)
  30004   This field  allows th e user to  add anothe r order fr om this di alog, when  the
  30005   "^DD",101. 41,101.41, 9,21,2,0)
  30006   initial or der is acc epted and  placed; if  set to YE S, the use r will be
  30007   "^DD",101. 41,101.41, 9,21,3,0)
  30008   asked "Add  another < dialog dis play text>  order?" t o allow fo r either
  30009   "^DD",101. 41,101.41, 9,21,4,0)
  30010   exiting th e processo r or addin g an addit ional orde r of the s ame type.
  30011   "^DD",101. 41,101.41, 9,21,5,0)
  30012   This field  can also  be set to  YES-DON'T  ASK to for ce the pro cessor to
  30013   "^DD",101. 41,101.41, 9,21,6,0)
  30014   automatica lly drop i nto prompt ing for an other orde r without  asking fir st.
  30015   "^DD",101. 41,101.41, 9,"DT")
  30016   2970616
  30017   "^DD",101. 41,101.41, 10,0)
  30018   ITEMS^101. 412IA^^10; 0
  30019   "^DD",101. 41,101.41, 10,21,0)
  30020   ^^5^5^2990 211^^^^
  30021   "^DD",101. 41,101.41, 10,21,1,0)
  30022   This field  contains  the compon ents for d ialogs:
  30023   "^DD",101. 41,101.41, 10,21,2,0)
  30024        Dialo gs      ->  prompts
  30025   "^DD",101. 41,101.41, 10,21,3,0)
  30026        Quick  orders ->  prompts ( completed)
  30027   "^DD",101. 41,101.41, 10,21,4,0)
  30028        Order  sets   ->  dialogs o r quick or ders
  30029   "^DD",101. 41,101.41, 10,21,5,0)
  30030        Menus         ->  dialogs,  quick orde rs, or ord er sets
  30031   "^DD",101. 41,101.41, 11,0)
  30032   DATA TYPE^ S^D:date/t ime;R:free  text date /time;F:fr ee text;N: numeric;S: set of cod es;Y:yes/n o;P:pointe r;W:word p rocessing; ^1;1^Q
  30033   "^DD",101. 41,101.41, 11,3)
  30034   Enter the  type of da ta to be c ollected a t this pro mpt.
  30035   "^DD",101. 41,101.41, 11,21,0)
  30036   ^^2^2^2950 823^^
  30037   "^DD",101. 41,101.41, 11,21,1,0)
  30038   This is th e type of  data being  prompted  for; this  field is u sed to def ine
  30039   "^DD",101. 41,101.41, 11,21,2,0)
  30040   a call to  the reader  (^DIR) in  most case s.
  30041   "^DD",101. 41,101.41, 11,23,0)
  30042   ^^1^1^2950 823^^
  30043   "^DD",101. 41,101.41, 11,23,1,0)
  30044   Used with  Prompt-typ e only.
  30045   "^DD",101. 41,101.41, 11,"DT")
  30046   2950407
  30047   "^DD",101. 41,101.41, 12,0)
  30048   DOMAIN^F^^ 1;2^K:$L(X )>235!($L( X)<1) X
  30049   "^DD",101. 41,101.41, 12,3)
  30050   Answer mus t be 1-235  character s in lengt h.
  30051   "^DD",101. 41,101.41, 12,21,0)
  30052   ^^3^3^2990 225^^^^
  30053   "^DD",101. 41,101.41, 12,21,1,0)
  30054   This is a  parameter  that may b e used to  further sp ecify the  data type.
  30055   "^DD",101. 41,101.41, 12,21,2,0)
  30056   The string  stored he re should  be appropr iate for t he second  ^-piece of
  30057   "^DD",101. 41,101.41, 12,21,3,0)
  30058   DIR(0) whe n used wit h the data  type fiel d.
  30059   "^DD",101. 41,101.41, 12,23,0)
  30060   ^^1^1^2990 225^^^^
  30061   "^DD",101. 41,101.41, 12,23,1,0)
  30062   Used with  Prompt-typ e only.
  30063   "^DD",101. 41,101.41, 12,"DT")
  30064   2990225
  30065   "^DD",101. 41,101.41, 13,0)
  30066   ID^F^^1;3^ K:$L(X)>10 !($L(X)<2)  X
  30067   "^DD",101. 41,101.41, 13,3)
  30068   Answer mus t be 2-10  characters  in length .
  30069   "^DD",101. 41,101.41, 13,21,0)
  30070   ^.001^20^2 0^3010727^ ^
  30071   "^DD",101. 41,101.41, 13,21,1,0)
  30072   This field  may conta in a singl e word ide ntifier wh ich will b e
  30073   "^DD",101. 41,101.41, 13,21,2,0)
  30074   stored wit h the user  response  in the Ord ers file # 100, where  it
  30075   "^DD",101. 41,101.41, 13,21,3,0)
  30076   will be in dexed for  quick refe rence to c ertain val ues in the
  30077   "^DD",101. 41,101.41, 13,21,4,0)
  30078   order dial og.  The f ollowing a re some ex amples of  values
  30079   "^DD",101. 41,101.41, 13,21,5,0)
  30080   currently  in use:
  30081   "^DD",101. 41,101.41, 13,21,6,0)
  30082    
  30083   "^DD",101. 41,101.41, 13,21,7,0)
  30084      START       -> Sta rt date/ti me
  30085   "^DD",101. 41,101.41, 13,21,8,0)
  30086      STOP        -> Sto p date/tim e
  30087   "^DD",101. 41,101.41, 13,21,9,0)
  30088      SCHEDUL E   -> Adm inistratio n Schedule
  30089   "^DD",101. 41,101.41, 13,21,10,0 )
  30090      ORDERAB LE  -> Ord erable Ite m
  30091   "^DD",101. 41,101.41, 13,21,11,0 )
  30092      DRUG        -> Dis pense Drug
  30093   "^DD",101. 41,101.41, 13,21,12,0 )
  30094      CANCEL      -> Can cel Future  Orders fl ag
  30095   "^DD",101. 41,101.41, 13,21,13,0 )
  30096      COMMENT     -> Wor d processi ng comment s
  30097   "^DD",101. 41,101.41, 13,21,14,0 )
  30098    
  30099   "^DD",101. 41,101.41, 13,21,15,0 )
  30100   These valu es must be  unique am ong entrie s within a n order di alog
  30101   "^DD",101. 41,101.41, 13,21,16,0 )
  30102   but do not  need to b e unique a cross the  entire fil e.  Be sur e to
  30103   "^DD",101. 41,101.41, 13,21,17,0 )
  30104   check the  IDs assign ed to gene ric text e ntries to  make sure  that
  30105   "^DD",101. 41,101.41, 13,21,18,0 )
  30106   all IDs ar e unique.   In order  to avoid p otential p roblems it 's
  30107   "^DD",101. 41,101.41, 13,21,19,0 )
  30108   recommende d that you  use uniqu e IDs for  any local  entries th at you
  30109   "^DD",101. 41,101.41, 13,21,20,0 )
  30110   create.
  30111   "^DD",101. 41,101.41, 13,"DT")
  30112   2960215
  30113   "^DD",101. 41,101.41, 17,0)
  30114   VALIDATION ^K^^7;E1,2 45^K:$L(X) >245 X D:$ D(X) ^DIM
  30115   "^DD",101. 41,101.41, 17,3)
  30116   This is St andard MUM PS code.
  30117   "^DD",101. 41,101.41, 17,9)
  30118   @
  30119   "^DD",101. 41,101.41, 17,21,0)
  30120   ^^3^3^2960 912^
  30121   "^DD",101. 41,101.41, 17,21,1,0)
  30122   This is MU MPS code t hat will b e executed  at the ti me of rele asing an
  30123   "^DD",101. 41,101.41, 17,21,2,0)
  30124   order crea ted with t his dialog ; dialog r esponses m ay be chec ked again
  30125   "^DD",101. 41,101.41, 17,21,3,0)
  30126   here befor e releasin g the orde r to the s ervice.
  30127   "^DD",101. 41,101.41, 17,"DT")
  30128   2960912
  30129   "^DD",101. 41,101.41, 19,0)
  30130   ADDITIONAL  TEXT^K^^9 ;E1,245^K: $L(X)>245  X D:$D(X)  ^DIM
  30131   "^DD",101. 41,101.41, 19,3)
  30132   This is St andard MUM PS code.
  30133   "^DD",101. 41,101.41, 19,9)
  30134   @
  30135   "^DD",101. 41,101.41, 19,21,0)
  30136   ^^3^3^2960 405^^
  30137   "^DD",101. 41,101.41, 19,21,1,0)
  30138   This is MU MPS code t hat will b e executed  when orde r ORIFN cr eated by t his
  30139   "^DD",101. 41,101.41, 19,21,2,0)
  30140   dialog is  about to b e displaye d; any str ing that s hould be a ppended to  the
  30141   "^DD",101. 41,101.41, 19,21,3,0)
  30142   order text  should be  returned  in Y.
  30143   "^DD",101. 41,101.41, 19,"DT")
  30144   2960405
  30145   "^DD",101. 41,101.41, 20,0)
  30146   DESCRIPTIO N^101.411^ ^2;0
  30147   "^DD",101. 41,101.41, 20,21,0)
  30148   ^^1^1^2971 219^
  30149   "^DD",101. 41,101.41, 20,21,1,0)
  30150   This is a  descriptio n of the d ialog and  its uses.
  30151   "^DD",101. 41,101.41, 21,0)
  30152   RESPONSES^ 101.416^^6 ;0
  30153   "^DD",101. 41,101.41, 21,21,0)
  30154   ^^2^2^2971 219^
  30155   "^DD",101. 41,101.41, 21,21,1,0)
  30156   This multi ple contai ns any res ponses to  prompts th at have be en pre-ans wered
  30157   "^DD",101. 41,101.41, 21,21,2,0)
  30158   to create  a quick or der.
  30159   "^DD",101. 41,101.41, 30,0)
  30160   ENTRY ACTI ON^K^^3;E1 ,245^K:$L( X)>245 X D :$D(X) ^DI M
  30161   "^DD",101. 41,101.41, 30,3)
  30162   This is St andard MUM PS code.
  30163   "^DD",101. 41,101.41, 30,9)
  30164   @
  30165   "^DD",101. 41,101.41, 30,21,0)
  30166   ^^4^4^2950 425^
  30167   "^DD",101. 41,101.41, 30,21,1,0)
  30168   This is MU MPS code t hat will b e executed  at the to p of a dia log, prior  to
  30169   "^DD",101. 41,101.41, 30,21,2,0)
  30170   the execut ion of any  prompts;  it may per form funct ions such  as listing
  30171   "^DD",101. 41,101.41, 30,21,3,0)
  30172   the recent  Radiology  exams bef ore orderi ng a new o ne, or ale rting the
  30173   "^DD",101. 41,101.41, 30,21,4,0)
  30174   user to an  existing  diet order  before ma king a cha nge.
  30175   "^DD",101. 41,101.41, 30,"DT")
  30176   2950425
  30177   "^DD",101. 41,101.41, 31,0)
  30178   QUICK SETU P^K^^3.1;E 1,245^K:$L (X)>245 X  D:$D(X) ^D IM
  30179   "^DD",101. 41,101.41, 31,3)
  30180   This is St andard MUM PS code.
  30181   "^DD",101. 41,101.41, 31,9)
  30182   @
  30183   "^DD",101. 41,101.41, 31,21,0)
  30184   ^^3^3^2970 113^
  30185   "^DD",101. 41,101.41, 31,21,1,0)
  30186   This is MU MPS code t hat will b e executed  in the pl ace of the  Entry Act ion
  30187   "^DD",101. 41,101.41, 31,21,2,0)
  30188   when creat ing quick  orders for  this dial og; variab les may be  set here
  30189   "^DD",101. 41,101.41, 31,21,3,0)
  30190   instead to  bypass th e usual de pendence o n specific  patient v alues.
  30191   "^DD",101. 41,101.41, 31,"DT")
  30192   2970113
  30193   "^DD",101. 41,101.41, 40,0)
  30194   EXIT ACTIO N^K^^4;E1, 245^K:$L(X )>245 X D: $D(X) ^DIM
  30195   "^DD",101. 41,101.41, 40,3)
  30196   This is St andard MUM PS code.
  30197   "^DD",101. 41,101.41, 40,9)
  30198   @
  30199   "^DD",101. 41,101.41, 40,21,0)
  30200   ^^2^2^2950 622^
  30201   "^DD",101. 41,101.41, 40,21,1,0)
  30202   This is MU MPS code t hat will b e executed  upon comp letion of  processing  the
  30203   "^DD",101. 41,101.41, 40,21,2,0)
  30204   dialog; it  is curren tly used o nly with d ialog-type  entries.
  30205   "^DD",101. 41,101.41, 40,"DT")
  30206   2950622
  30207   "^DD",101. 41,101.41, 50,0)
  30208   CONTROLS^1 01.415A^^5 0;0
  30209   "^DD",101. 41,101.41, 51,0)
  30210   COLUMN WID TH^NJ3,0^^ 5;1^K:+X'= X!(X>240)! (X<20)!(X? .E1"."1N.N ) X
  30211   "^DD",101. 41,101.41, 51,1,0)
  30212   ^.1
  30213   "^DD",101. 41,101.41, 51,1,1,0)
  30214   101.41^AM5 1^MUMPS
  30215   "^DD",101. 41,101.41, 51,1,1,1)
  30216   D REDO^ORD D41
  30217   "^DD",101. 41,101.41, 51,1,1,2)
  30218   D REDO^ORD D41
  30219   "^DD",101. 41,101.41, 51,1,1,"%D ",0)
  30220   ^^1^1^2990 210^
  30221   "^DD",101. 41,101.41, 51,1,1,"%D ",1,0)
  30222   Update TIM ESTAMP whe never COLU MN WIDTH i s changed.
  30223   "^DD",101. 41,101.41, 51,1,1,"DT ")
  30224   2990210
  30225   "^DD",101. 41,101.41, 51,3)
  30226   Type a Num ber betwee n 20 and 2 40, 0 Deci mal Digits
  30227   "^DD",101. 41,101.41, 51,21,0)
  30228   ^^2^2^2950 623^
  30229   "^DD",101. 41,101.41, 51,21,1,0)
  30230   This is th e width, i n characte rs, for ea ch column  in a menu.   For exam ple,
  30231   "^DD",101. 41,101.41, 51,21,2,0)
  30232   to have 3  columns on  an 80 cha racter dev ice, enter  a width o f 26.
  30233   "^DD",101. 41,101.41, 51,"DT")
  30234   2990210
  30235   "^DD",101. 41,101.41, 52,0)
  30236   MNEMONIC W IDTH^NJ1,0 ^^5;2^K:+X '=X!(X>9)! (X<1)!(X?. E1"."1N.N)  X
  30237   "^DD",101. 41,101.41, 52,1,0)
  30238   ^.1
  30239   "^DD",101. 41,101.41, 52,1,1,0)
  30240   101.41^AM5 2^MUMPS
  30241   "^DD",101. 41,101.41, 52,1,1,1)
  30242   D REDO^ORD D41
  30243   "^DD",101. 41,101.41, 52,1,1,2)
  30244   D REDO^ORD D41
  30245   "^DD",101. 41,101.41, 52,1,1,"%D ",0)
  30246   ^^1^1^2990 210^
  30247   "^DD",101. 41,101.41, 52,1,1,"%D ",1,0)
  30248   Update TIM ESTAMP whe never MNEM ONIC WIDTH  is change d.
  30249   "^DD",101. 41,101.41, 52,1,1,"DT ")
  30250   2990210
  30251   "^DD",101. 41,101.41, 52,3)
  30252   Type a Num ber betwee n 1 and 9,  0 Decimal  Digits
  30253   "^DD",101. 41,101.41, 52,21,0)
  30254   ^^2^2^2950 623^
  30255   "^DD",101. 41,101.41, 52,21,1,0)
  30256   This field  allows th e width of  item mnem onics to b e varied;  the defaul t
  30257   "^DD",101. 41,101.41, 52,21,2,0)
  30258   value is 5 .
  30259   "^DD",101. 41,101.41, 52,"DT")
  30260   2990210
  30261   "^DD",101. 41,101.41, 53,0)
  30262   PATH SWITC H^S^1:YES; 0:NO;^5;3^ Q
  30263   "^DD",101. 41,101.41, 53,3)
  30264   Enter YES  if this me nu should  be redispl ayed when  traversing  back up t he menu tr ee.
  30265   "^DD",101. 41,101.41, 53,21,0)
  30266   ^^5^5^2950 623^
  30267   "^DD",101. 41,101.41, 53,21,1,0)
  30268   This switc h allows t he user, w hen traver sing back  UP the tre e of menus  and
  30269   "^DD",101. 41,101.41, 53,21,2,0)
  30270   items, to  select a n ew path ba ck down th e tree.  I n other wo rds, the m enu
  30271   "^DD",101. 41,101.41, 53,21,3,0)
  30272   is redispl ayed when  returning  to that me nu's level  in the tr ee and
  30273   "^DD",101. 41,101.41, 53,21,4,0)
  30274   processing  back down  the tree  is possibl e from tha t point.   If nothing  is
  30275   "^DD",101. 41,101.41, 53,21,5,0)
  30276   selected f rom the me nu, the pa th continu es back up  the tree.
  30277   "^DD",101. 41,101.41, 53,"DT")
  30278   2950623
  30279   "^DD",101. 41,101.41, 54,0)
  30280   LISTBOX TE XT^F^^5;4^ K:$L(X)>30 !($L(X)<1)  X
  30281   "^DD",101. 41,101.41, 54,3)
  30282   Answer mus t be 1-30  characters  in length .
  30283   "^DD",101. 41,101.41, 54,"DT")
  30284   2960524
  30285   "^DD",101. 41,101.41, 55,0)
  30286   WINDOW FOR M ID^NJ4,0 ^^5;5^K:+X '=X!(X>999 9)!(X<0)!( X?.E1"."1N .N) X
  30287   "^DD",101. 41,101.41, 55,3)
  30288   Type a Num ber betwee n 0 and 99 99, 0 Deci mal Digits
  30289   "^DD",101. 41,101.41, 55,21,0)
  30290   ^.001^23^2 3^3010727^ ^
  30291   "^DD",101. 41,101.41, 55,21,1,0)
  30292   This field  tells the  GUI DELPH I code whi ch form to  use to pr ocess the
  30293   "^DD",101. 41,101.41, 55,21,2,0)
  30294   order dial og.  Each  number rep resents a  unique for m.  Follow ing are so me
  30295   "^DD",101. 41,101.41, 55,21,3,0)
  30296   of the mor e common c odes and t heir corre sponding f orm in DEL PHI.
  30297   "^DD",101. 41,101.41, 55,21,4,0)
  30298    
  30299   "^DD",101. 41,101.41, 55,21,5,0)
  30300       Form N ame     Wi ndows Form  ID
  30301   "^DD",101. 41,101.41, 55,21,6,0)
  30302       ------ ---     -- ---------- ---
  30303   "^DD",101. 41,101.41, 55,21,7,0)
  30304     OD_ACTIV ITY            100
  30305   "^DD",101. 41,101.41, 55,21,8,0)
  30306     OD_ALLER GY             105
  30307   "^DD",101. 41,101.41, 55,21,9,0)
  30308     OD_CONSU LT             110
  30309   "^DD",101. 41,101.41, 55,21,10,0 )
  30310     OD_PROCE DURE           112
  30311   "^DD",101. 41,101.41, 55,21,11,0 )
  30312     OD_DIET_ TXT            115
  30313   "^DD",101. 41,101.41, 55,21,12,0 )
  30314     OD_DIET                 117
  30315   "^DD",101. 41,101.41, 55,21,13,0 )
  30316     OD_LAB                  120
  30317   "^DD",101. 41,101.41, 55,21,14,0 )
  30318     OD_MEDIN PT             130
  30319   "^DD",101. 41,101.41, 55,21,15,0 )
  30320     OD_MEDS                 135
  30321   "^DD",101. 41,101.41, 55,21,16,0 )
  30322     OD_MEDOU TPT            140
  30323   "^DD",101. 41,101.41, 55,21,17,0 )
  30324     OD_NURSI NG             150
  30325   "^DD",101. 41,101.41, 55,21,18,0 )
  30326     OD_MISC                 151
  30327   "^DD",101. 41,101.41, 55,21,19,0 )
  30328     OD_GENER IC             152
  30329   "^DD",101. 41,101.41, 55,21,20,0 )
  30330     OD_IMAGI NG             160
  30331   "^DD",101. 41,101.41, 55,21,21,0 )
  30332     OD_VITAL S              171 
  30333   "^DD",101. 41,101.41, 55,21,22,0 )
  30334     OD_MEDIV                180
  30335   "^DD",101. 41,101.41, 55,21,23,0 )
  30336     OD_TEXTO NLY            999
  30337   "^DD",101. 41,101.41, 55,"DT")
  30338   2960804
  30339   "^DD",101. 41,101.41, 56,0)
  30340   CREATE PAR ENT ORDER^ S^1:YES;0: NO;^5;6^Q
  30341   "^DD",101. 41,101.41, 56,3)
  30342   Enter YES  if a paren t order sh ould be cr eated for  this order  set
  30343   "^DD",101. 41,101.41, 56,21,0)
  30344   ^^6^6^2970 227^
  30345   "^DD",101. 41,101.41, 56,21,1,0)
  30346   This flag  indicates  whether a  parent ord er should  be created  to group
  30347   "^DD",101. 41,101.41, 56,21,2,0)
  30348   together a ll the ord ers create d by this  order set;  this flag  is only
  30349   "^DD",101. 41,101.41, 56,21,3,0)
  30350   valid with  SET type  order dial ogs.  If t his value  is YES, a  parent
  30351   "^DD",101. 41,101.41, 56,21,4,0)
  30352   order will  be create d, and onl y the pare nt will be  presented  on the
  30353   "^DD",101. 41,101.41, 56,21,5,0)
  30354   orders lis t for disp lay and ac tion; NO w ill preven t a parent  from bein g
  30355   "^DD",101. 41,101.41, 56,21,6,0)
  30356   created an d all orde rs will be  created a nd display ed indepen dently.
  30357   "^DD",101. 41,101.41, 56,"DT")
  30358   2970227
  30359   "^DD",101. 41,101.41, 57,0)
  30360   DISPLAY SU BHEADER^S^ 1:YES;0:NO ;^5;7^Q
  30361   "^DD",101. 41,101.41, 57,3)
  30362   Enter YES  if a subhe ader shoul d be displ ayed as ea ch order i n this set  is proces sed
  30363   "^DD",101. 41,101.41, 57,21,0)
  30364   ^^3^3^2970 227^
  30365   "^DD",101. 41,101.41, 57,21,1,0)
  30366   This flag  indicates  whether a  subheader  is to be d isplayed f or each or der
  30367   "^DD",101. 41,101.41, 57,21,2,0)
  30368   in this se t as it is  processed  and place d; this fl ag is only  valid wit h
  30369   "^DD",101. 41,101.41, 57,21,3,0)
  30370   SET type o rder dialo gs.
  30371   "^DD",101. 41,101.41, 57,"DT")
  30372   2970227
  30373   "^DD",101. 41,101.41, 58,0)
  30374   AUTO-ACCEP T QUICK OR DER^S^1:YE S;^5;8^Q
  30375   "^DD",101. 41,101.41, 58,3)
  30376   Enter 'Yes ' if the o rder shoul d be place d without  displaying  the dialo g window.
  30377   "^DD",101. 41,101.41, 58,21,0)
  30378   ^^2^2^2980 902^
  30379   "^DD",101. 41,101.41, 58,21,1,0)
  30380   This can b e set to y es for a q uick order  so that i t can be p laced simp ly
  30381   "^DD",101. 41,101.41, 58,21,2,0)
  30382   by clickin g on it in  the GUI ( no orderin g dialog i s displaye d).
  30383   "^DD",101. 41,101.41, 58,"DT")
  30384   2980902
  30385   "^DD",101. 41,101.41, 99,0)
  30386   TIMESTAMP^ F^^99;1^K: $L(X)>15!( $L(X)<1) X
  30387   "^DD",101. 41,101.41, 99,1,0)
  30388   ^.1
  30389   "^DD",101. 41,101.41, 99,1,1,0)
  30390   101.41^AM^ MUMPS
  30391   "^DD",101. 41,101.41, 99,1,1,1)
  30392   D SET^ORDD 41(DA)
  30393   "^DD",101. 41,101.41, 99,1,1,2)
  30394   D KILL^ORD D41(DA)
  30395   "^DD",101. 41,101.41, 99,1,1,"%D ",0)
  30396   ^^2^2^2990 210^
  30397   "^DD",101. 41,101.41, 99,1,1,"%D ",1,0)
  30398   Recompiles  order dia log menus  in ^XUTL(" XQORM",<di alog#>_";O RD(101.41, ")
  30399   "^DD",101. 41,101.41, 99,1,1,"%D ",2,0)
  30400   whenever f ields nece ssary to d isplaying  the menu a re changed .
  30401   "^DD",101. 41,101.41, 99,1,1,"DT ")
  30402   2990210
  30403   "^DD",101. 41,101.41, 99,3)
  30404   Answer mus t be 1-15  characters  in length .
  30405   "^DD",101. 41,101.41, 99,21,0)
  30406   ^^2^2^2980 501^
  30407   "^DD",101. 41,101.41, 99,21,1,0)
  30408   For menus,  this cont ains the $ H time the  menu was  last compi led for us e
  30409   "^DD",101. 41,101.41, 99,21,2,0)
  30410   with the U nwinder ut ility (^XQ OR).
  30411   "^DD",101. 41,101.41, 99,"DT")
  30412   2990210
  30413   "^DD",101. 41,101.411 ,0)
  30414   DESCRIPTIO N SUB-FIEL D^^.01^1
  30415   "^DD",101. 41,101.411 ,0,"DT")
  30416   2950407
  30417   "^DD",101. 41,101.411 ,0,"NM","D ESCRIPTION ")
  30418  
  30419   "^DD",101. 41,101.411 ,0,"UP")
  30420   101.41
  30421   "^DD",101. 41,101.411 ,.01,0)
  30422   DESCRIPTIO N^W^^0;1^Q
  30423   "^DD",101. 41,101.411 ,.01,3)
  30424   Enter a de scription  of this di alog.
  30425   "^DD",101. 41,101.411 ,.01,21,0)
  30426   ^^1^1^2950 425^^
  30427   "^DD",101. 41,101.411 ,.01,21,1, 0)
  30428   This field  contains  a descript ion of the  content a nd use of  this dialo g.
  30429   "^DD",101. 41,101.411 ,.01,"DT")
  30430   2950407
  30431   "^DD",101. 41,101.412 ,0)
  30432   ITEMS SUB- FIELD^^117 ^37
  30433   "^DD",101. 41,101.412 ,0,"DT")
  30434   2971117
  30435   "^DD",101. 41,101.412 ,0,"ID","W RITE")
  30436   N OR0,ORNM  S OR0=^(0 ) I $P(OR0 ,U,2) S OR NM=$P($G(^ ORD(101.41 ,+$P(OR0,U ,2),0)),U)  D:$L(ORNM ) EN^DDIOL (ORNM,,"?1 0")
  30437   "^DD",101. 41,101.412 ,0,"IX","A TXT",101.4 12,21)
  30438  
  30439   "^DD",101. 41,101.412 ,0,"IX","B ",101.412, .01)
  30440  
  30441   "^DD",101. 41,101.412 ,0,"IX","D ",101.412, 2)
  30442  
  30443   "^DD",101. 41,101.412 ,0,"IX","D AD",101.41 2,1)
  30444  
  30445   "^DD",101. 41,101.412 ,0,"IX","D AD1",101.4 12,.01)
  30446  
  30447   "^DD",101. 41,101.412 ,0,"NM","I TEMS")
  30448  
  30449   "^DD",101. 41,101.412 ,0,"UP")
  30450   101.41
  30451   "^DD",101. 41,101.412 ,.01,0)
  30452   SEQUENCE^M NJ5,1^^0;1 ^K:+X'=X!( X>999.9)!( X<.1)!(X?. E1"."2N.N)  X
  30453   "^DD",101. 41,101.412 ,.01,1,0)
  30454   ^.1
  30455   "^DD",101. 41,101.412 ,.01,1,1,0 )
  30456   101.412^B
  30457   "^DD",101. 41,101.412 ,.01,1,1,1 )
  30458   S ^ORD(101 .41,DA(1), 10,"B",$E( X,1,30),DA )=""
  30459   "^DD",101. 41,101.412 ,.01,1,1,2 )
  30460   K ^ORD(101 .41,DA(1), 10,"B",$E( X,1,30),DA )
  30461   "^DD",101. 41,101.412 ,.01,1,2,0 )
  30462   101.412^DA D1^MUMPS
  30463   "^DD",101. 41,101.412 ,.01,1,2,1 )
  30464   N ORP S OR P=$P(^ORD( 101.41,DA( 1),10,DA,0 ),U,11) S: ORP ^ORD(1 01.41,DA(1 ),10,"DAD" ,ORP,X,DA) =""
  30465   "^DD",101. 41,101.412 ,.01,1,2,2 )
  30466   N ORP S OR P=$P(^ORD( 101.41,DA( 1),10,DA,0 ),U,11) K: ORP ^ORD(1 01.41,DA(1 ),10,"DAD" ,ORP,X,DA)
  30467   "^DD",101. 41,101.412 ,.01,1,2," %D",0)
  30468   ^^1^1^2950 511^
  30469   "^DD",101. 41,101.412 ,.01,1,2," %D",1,0)
  30470   Allows ret rieval of  'child' pr ompts in s equence by  parent.
  30471   "^DD",101. 41,101.412 ,.01,1,2," DT")
  30472   2950511
  30473   "^DD",101. 41,101.412 ,.01,1,3,0 )
  30474   101.41^AMM ^MUMPS
  30475   "^DD",101. 41,101.412 ,.01,1,3,1 )
  30476   D REDOX^OR DD41
  30477   "^DD",101. 41,101.412 ,.01,1,3,2 )
  30478   D REDOX^OR DD41
  30479   "^DD",101. 41,101.412 ,.01,1,3," %D",0)
  30480   ^^1^1^2990 210^
  30481   "^DD",101. 41,101.412 ,.01,1,3," %D",1,0)
  30482   Update TIM ESTAMP whe never SEQU ENCE is ch anged.
  30483   "^DD",101. 41,101.412 ,.01,1,3," DT")
  30484   2990210
  30485   "^DD",101. 41,101.412 ,.01,3)
  30486   Type a Num ber betwee n .1 and 9 99.9, 1 De cimal Digi t
  30487   "^DD",101. 41,101.412 ,.01,21,0)
  30488   ^^2^2^2971 117^^^^
  30489   "^DD",101. 41,101.412 ,.01,21,1, 0)
  30490   This field  specifies  the order  in which  this item  will be di splayed or
  30491   "^DD",101. 41,101.412 ,.01,21,2, 0)
  30492   processed.
  30493   "^DD",101. 41,101.412 ,.01,"DT")
  30494   2990210
  30495   "^DD",101. 41,101.412 ,.1,0)
  30496   INPUT TRAN SFORM^K^^. 1;E1,245^K :$L(X)>245  X D:$D(X)  ^DIM
  30497   "^DD",101. 41,101.412 ,.1,3)
  30498   This is St andard MUM PS code.
  30499   "^DD",101. 41,101.412 ,.1,9)
  30500   @
  30501   "^DD",101. 41,101.412 ,.1,21,0)
  30502   ^^2^2^2950 816^
  30503   "^DD",101. 41,101.412 ,.1,21,1,0 )
  30504   This is co de that wi ll be used  as the th ird piece  of DIR(0)  when askin g
  30505   "^DD",101. 41,101.412 ,.1,21,2,0 )
  30506   this promp t.
  30507   "^DD",101. 41,101.412 ,.1,"DT")
  30508   2950816
  30509   "^DD",101. 41,101.412 ,1,0)
  30510   PARENT^P10 1.41'^ORD( 101.41,^0; 11^Q
  30511   "^DD",101. 41,101.412 ,1,1,0)
  30512   ^.1
  30513   "^DD",101. 41,101.412 ,1,1,1,0)
  30514   101.412^DA D^MUMPS
  30515   "^DD",101. 41,101.412 ,1,1,1,1)
  30516   S ^ORD(101 .41,DA(1), 10,"DAD",X ,$P(^ORD(1 01.41,DA(1 ),10,DA,0) ,U),DA)=""
  30517   "^DD",101. 41,101.412 ,1,1,1,2)
  30518   K ^ORD(101 .41,DA(1), 10,"DAD",X ,$P(^ORD(1 01.41,DA(1 ),10,DA,0) ,U),DA)
  30519   "^DD",101. 41,101.412 ,1,1,1,"%D ",0)
  30520   ^^1^1^2950 511^^
  30521   "^DD",101. 41,101.412 ,1,1,1,"%D ",1,0)
  30522   Allows ret rieval of  'child' pr ompts in s equence by  parent.
  30523   "^DD",101. 41,101.412 ,1,1,1,"DT ")
  30524   2950511
  30525   "^DD",101. 41,101.412 ,1,3)
  30526   If this pr ompt is su bordinate  to another  in this d ialog, ent er the par ent prompt  here
  30527   "^DD",101. 41,101.412 ,1,21,0)
  30528   ^^4^4^2950 511^
  30529   "^DD",101. 41,101.412 ,1,21,1,0)
  30530   This field  controls  the behavi or of this  prompt.   If a paren t is defin ed
  30531   "^DD",101. 41,101.412 ,1,21,2,0)
  30532   here, this  prompt wi ll be aske d from wit hin the pa rent's dia log; when  it
  30533   "^DD",101. 41,101.412 ,1,21,3,0)
  30534   is invoked  independe ntly based  on its po sition seq uence numb er, the ch ild
  30535   "^DD",101. 41,101.412 ,1,21,4,0)
  30536   prompt wil l be ignor ed.
  30537   "^DD",101. 41,101.412 ,1,"DT")
  30538   2950511
  30539   "^DD",101. 41,101.412 ,2,0)
  30540   ITEM^P101. 41'X^ORD(1 01.41,^0;2 ^D TREE^OR DD41
  30541   "^DD",101. 41,101.412 ,2,1,0)
  30542   ^.1
  30543   "^DD",101. 41,101.412 ,2,1,1,0)
  30544   101.41^AD
  30545   "^DD",101. 41,101.412 ,2,1,1,1)
  30546   S ^ORD(101 .41,"AD",$ E(X,1,30), DA(1),DA)= ""
  30547   "^DD",101. 41,101.412 ,2,1,1,2)
  30548   K ^ORD(101 .41,"AD",$ E(X,1,30), DA(1),DA)
  30549   "^DD",101. 41,101.412 ,2,1,1,"DT ")
  30550   2950123
  30551   "^DD",101. 41,101.412 ,2,1,2,0)
  30552   101.412^D
  30553   "^DD",101. 41,101.412 ,2,1,2,1)
  30554   S ^ORD(101 .41,DA(1), 10,"D",$E( X,1,30),DA )=""
  30555   "^DD",101. 41,101.412 ,2,1,2,2)
  30556   K ^ORD(101 .41,DA(1), 10,"D",$E( X,1,30),DA )
  30557   "^DD",101. 41,101.412 ,2,1,2,"DT ")
  30558   2950411
  30559   "^DD",101. 41,101.412 ,2,1,3,0)
  30560   101.41^AMM 2^MUMPS
  30561   "^DD",101. 41,101.412 ,2,1,3,1)
  30562   D REDOX^OR DD41
  30563   "^DD",101. 41,101.412 ,2,1,3,2)
  30564   D REDOX^OR DD41
  30565   "^DD",101. 41,101.412 ,2,1,3,"%D ",0)
  30566   ^^1^1^2990 210^
  30567   "^DD",101. 41,101.412 ,2,1,3,"%D ",1,0)
  30568   Update TIM ESTAMP whe never ITEM  is change d.
  30569   "^DD",101. 41,101.412 ,2,1,3,"DT ")
  30570   2990210
  30571   "^DD",101. 41,101.412 ,2,3)
  30572   Enter an o rder dialo g; a dialo g that is  an ancesto r may not  also be a  sub-item.
  30573   "^DD",101. 41,101.412 ,2,21,0)
  30574   ^^3^3^2950 123^
  30575   "^DD",101. 41,101.412 ,2,21,1,0)
  30576   This field  points to  an order  dialog whi ch is subo rdinate to  this dial og.
  30577   "^DD",101. 41,101.412 ,2,21,2,0)
  30578   NOTE:  The  parent di alog menu  or one of  its ancest ors may no t be enter ed
  30579   "^DD",101. 41,101.412 ,2,21,3,0)
  30580   as an item .
  30581   "^DD",101. 41,101.412 ,2,"DT")
  30582   2990217
  30583   "^DD",101. 41,101.412 ,3,0)
  30584   MNEMONIC^F X^^0;3^K:$ L(X)>4!($L (X)<1)!(+X =X&($L(X," .")>1))!($ $CHKMNE^OR UTL(X)) X
  30585   "^DD",101. 41,101.412 ,3,1,0)
  30586   ^.1
  30587   "^DD",101. 41,101.412 ,3,1,1,0)
  30588   101.41^AMM 3^MUMPS
  30589   "^DD",101. 41,101.412 ,3,1,1,1)
  30590   D REDOX^OR DD41
  30591   "^DD",101. 41,101.412 ,3,1,1,2)
  30592   D REDOX^OR DD41
  30593   "^DD",101. 41,101.412 ,3,1,1,"%D ",0)
  30594   ^^1^1^2990 210^
  30595   "^DD",101. 41,101.412 ,3,1,1,"%D ",1,0)
  30596   Update TIM ESTAMP whe never MNEM ONIC is ch anged.
  30597   "^DD",101. 41,101.412 ,3,1,1,"DT ")
  30598   2990210
  30599   "^DD",101. 41,101.412 ,3,3)
  30600   Enter a mn emonic to  be used wh en this di alog is di splayed fo r selectio n, 1-4 cha racters in  length wi th no deci mal places  if numeri c. Standar d list man ager mnemo nics may n ot be used .
  30601   "^DD",101. 41,101.412 ,3,21,0)
  30602   ^.001^2^2^ 3010727^^^ ^
  30603   "^DD",101. 41,101.412 ,3,21,1,0)
  30604   This is a  short abbr eviation f or this it em dialog  to be used  when this
  30605   "^DD",101. 41,101.412 ,3,21,2,0)
  30606   dialog is  displayed  for select ion.
  30607   "^DD",101. 41,101.412 ,3,"DT")
  30608   3000822
  30609   "^DD",101. 41,101.412 ,4,0)
  30610   DISPLAY TE XT^FX^^0;4 ^K:$L(X)>8 0!($L(X)<1 )!($$CHKNA M^ORUTL(X) ) X
  30611   "^DD",101. 41,101.412 ,4,1,0)
  30612   ^.1
  30613   "^DD",101. 41,101.412 ,4,1,1,0)
  30614   101.41^AMM 4^MUMPS
  30615   "^DD",101. 41,101.412 ,4,1,1,1)
  30616   D REDOX^OR DD41
  30617   "^DD",101. 41,101.412 ,4,1,1,2)
  30618   D REDOX^OR DD41
  30619   "^DD",101. 41,101.412 ,4,1,1,"%D ",0)
  30620   ^^1^1^2990 210^
  30621   "^DD",101. 41,101.412 ,4,1,1,"%D ",1,0)
  30622   Update TIM ESTAMP whe never DISP LAY TEXT i s changed.
  30623   "^DD",101. 41,101.412 ,4,1,1,"DT ")
  30624   2990210
  30625   "^DD",101. 41,101.412 ,4,3)
  30626   Answer mus t be 1-80  characters  in length  and canno t contain  a semicolo n (;), a c omma (,),  an up-arro w (^), a d ash (-), o r an equal  sign (=).
  30627   "^DD",101. 41,101.412 ,4,21,0)
  30628   ^.001^2^2^ 3010419^^^ ^
  30629   "^DD",101. 41,101.412 ,4,21,1,0)
  30630   This field  allows th e text tha t normally  appears f or this it em to be
  30631   "^DD",101. 41,101.412 ,4,21,2,0)
  30632   replaced w ith altern ate text f or use in  this dialo g or menu.
  30633   "^DD",101. 41,101.412 ,4,"DT")
  30634   3000823
  30635   "^DD",101. 41,101.412 ,5,0)
  30636   DISPLAY ON LY?^S^0:NO ;1:YES;2:Y ES-HEADER; ^0;5^Q
  30637   "^DD",101. 41,101.412 ,5,1,0)
  30638   ^.1
  30639   "^DD",101. 41,101.412 ,5,1,1,0)
  30640   101.41^AMM 5^MUMPS
  30641   "^DD",101. 41,101.412 ,5,1,1,1)
  30642   D REDOX^OR DD41
  30643   "^DD",101. 41,101.412 ,5,1,1,2)
  30644   D REDOX^OR DD41
  30645   "^DD",101. 41,101.412 ,5,1,1,"%D ",0)
  30646   ^^1^1^2990 210^
  30647   "^DD",101. 41,101.412 ,5,1,1,"%D ",1,0)
  30648   Update TIM ESTAMP whe never DISP LAY ONLY?  is changed .
  30649   "^DD",101. 41,101.412 ,5,1,1,"DT ")
  30650   2990210
  30651   "^DD",101. 41,101.412 ,5,3)
  30652   Enter YES  if this it em is text  for displ ay only an d not a se lectable i tem.
  30653   "^DD",101. 41,101.412 ,5,21,0)
  30654   ^^3^3^2970 409^^^^
  30655   "^DD",101. 41,101.412 ,5,21,1,0)
  30656   This field  identifie s an item  as being f ree text f or display  purposes
  30657   "^DD",101. 41,101.412 ,5,21,2,0)
  30658   only.  The  text in t he Display  Text fiel d will be  displayed,  but it
  30659   "^DD",101. 41,101.412 ,5,21,3,0)
  30660   is not sel ectable; i f designat ed as a he ader, the  text will  be underli ned.
  30661   "^DD",101. 41,101.412 ,5,"DT")
  30662   2990210
  30663   "^DD",101. 41,101.412 ,6,0)
  30664   REQUIRED^S ^1:YES;0:N O;^0;6^Q
  30665   "^DD",101. 41,101.412 ,6,3)
  30666   Enter YES  if a respo nse to thi s prompt i s mandator y.
  30667   "^DD",101. 41,101.412 ,6,21,0)
  30668   ^^1^1^2950 407^
  30669   "^DD",101. 41,101.412 ,6,21,1,0)
  30670   This field  indicates  that the  user must  enter a re sponse to  this promp t.
  30671   "^DD",101. 41,101.412 ,6,"DT")
  30672   2950407
  30673   "^DD",101. 41,101.412 ,7,0)
  30674   MULTIPLE V ALUED^S^1: YES;0:NO;^ 0;7^Q
  30675   "^DD",101. 41,101.412 ,7,3)
  30676   Enter YES  if this pr ompt is to  be asked  multiple t imes.
  30677   "^DD",101. 41,101.412 ,7,21,0)
  30678   ^^3^3^2950 407^
  30679   "^DD",101. 41,101.412 ,7,21,1,0)
  30680   This field  determine s if this  prompt wil l be allow ed to have  multiple
  30681   "^DD",101. 41,101.412 ,7,21,2,0)
  30682   values, or  be prompt ed for onl y once; if  this prom pt is a su b-dialog,
  30683   "^DD",101. 41,101.412 ,7,21,3,0)
  30684   the entire  dialog wi ll be aske d once or  many times , as a gro up.
  30685   "^DD",101. 41,101.412 ,7,"DT")
  30686   2950407
  30687   "^DD",101. 41,101.412 ,7.1,0)
  30688   MAX NUMBER  OF MULTIP LES^NJ2,0^ ^0;12^K:+X '=X!(X>99) !(X<2)!(X? .E1"."1N.N ) X
  30689   "^DD",101. 41,101.412 ,7.1,3)
  30690   Type a Num ber betwee n 2 and 99 , 0 Decima l Digits
  30691   "^DD",101. 41,101.412 ,7.1,21,0)
  30692   ^^4^4^2950 815^
  30693   "^DD",101. 41,101.412 ,7.1,21,1, 0)
  30694   This is th e maximum  number of  values tha t may be e ntered for  this prom pt,
  30695   "^DD",101. 41,101.412 ,7.1,21,2, 0)
  30696   if it is f lagged as  being mult iple-value d.  For ex ample, a d iet order  may
  30697   "^DD",101. 41,101.412 ,7.1,21,3, 0)
  30698   have up to  5 diet mo dification s entered,  where 5 i s the maxi mum allowe d
  30699   "^DD",101. 41,101.412 ,7.1,21,4, 0)
  30700   that would  be entere d here.
  30701   "^DD",101. 41,101.412 ,7.1,"DT")
  30702   2950815
  30703   "^DD",101. 41,101.412 ,7.2,0)
  30704   TITLE^F^^0 ;13^K:$L(X )>30!($L(X )<3) X
  30705   "^DD",101. 41,101.412 ,7.2,3)
  30706   Answer mus t be 3-30  characters  in length .
  30707   "^DD",101. 41,101.412 ,7.2,21,0)
  30708   ^^8^8^2970 430^^
  30709   "^DD",101. 41,101.412 ,7.2,21,1, 0)
  30710   This is te xt that wi ll be used  in place  of the pro mpt when t he order i s
  30711   "^DD",101. 41,101.412 ,7.2,21,2, 0)
  30712   displayed  for place,  edit, or  cancel, or  at the to p of a mul tiple-valu ed
  30713   "^DD",101. 41,101.412 ,7.2,21,3, 0)
  30714   prompt.  T he Display  Text for  the prompt  will be u sed togeth er with th e
  30715   "^DD",101. 41,101.412 ,7.2,21,4, 0)
  30716   instance n umber to p rompt for  user input ; for exam ple if Tit le="Lab Te sts:"
  30717   "^DD",101. 41,101.412 ,7.2,21,5, 0)
  30718   and Displa y Text="Te st:" the u ser would  see
  30719   "^DD",101. 41,101.412 ,7.2,21,6, 0)
  30720     Lab Test s:
  30721   "^DD",101. 41,101.412 ,7.2,21,7, 0)
  30722     1. Test:
  30723   "^DD",101. 41,101.412 ,7.2,21,8, 0)
  30724     2. Test:
  30725   "^DD",101. 41,101.412 ,7.2,"DT")
  30726   2950815
  30727   "^DD",101. 41,101.412 ,7.3,0)
  30728   PROMPT^F^^ 0;14^K:$L( X)>10!($L( X)<1) X
  30729   "^DD",101. 41,101.412 ,7.3,3)
  30730   Answer mus t be 1-10  characters  in length .
  30731   "^DD",101. 41,101.412 ,7.3,21,0)
  30732   ^^3^3^2970 618^
  30733   "^DD",101. 41,101.412 ,7.3,21,1, 0)
  30734   This field  contains  text that  will be ap pended to  the beginn ing of the
  30735   "^DD",101. 41,101.412 ,7.3,21,2, 0)
  30736   display te xt when pr ompting fo r addition al values;  if this f ield is
  30737   "^DD",101. 41,101.412 ,7.3,21,3, 0)
  30738   empty, the n "Another  " will be  used.
  30739   "^DD",101. 41,101.412 ,7.3,"DT")
  30740   2970618
  30741   "^DD",101. 41,101.412 ,8,0)
  30742   ASK ON EDI T ONLY^S^1 :YES;0:NO; ^0;8^Q
  30743   "^DD",101. 41,101.412 ,8,3)
  30744   Enter YES  if this pr ompt shoul d not be a sked initi ally when  creating t his order,  only if t he user ch ooses to e dit the or der.
  30745   "^DD",101. 41,101.412 ,8,21,0)
  30746   ^^4^4^2960 112^^^
  30747   "^DD",101. 41,101.412 ,8,21,1,0)
  30748   This field  determine s the beha viour of t he dialog  driver for  this prom pt;
  30749   "^DD",101. 41,101.412 ,8,21,2,0)
  30750   if no valu e or the d efined def ault is us ually corr ect for th is prompt,
  30751   "^DD",101. 41,101.412 ,8,21,3,0)
  30752   enter YES  here to ha ve this pr ompt skipp ed on the  first pass  through t his
  30753   "^DD",101. 41,101.412 ,8,21,4,0)
  30754   dialog whe n creating  an order.
  30755   "^DD",101. 41,101.412 ,8,"DT")
  30756   2950407
  30757   "^DD",101. 41,101.412 ,9,0)
  30758   ASK ON ACT ION^F^^0;9 ^K:$L(X)>3 !($L(X)<1)  X
  30759   "^DD",101. 41,101.412 ,9,3)
  30760   Answer mus t be 1-3 c haracters  in length.
  30761   "^DD",101. 41,101.412 ,9,21,0)
  30762   ^^6^6^2970 708^^^
  30763   "^DD",101. 41,101.412 ,9,21,1,0)
  30764   This field  determine s the beha viour of t he dialog  driver for  this prom pt
  30765   "^DD",101. 41,101.412 ,9,21,2,0)
  30766   when takin g a partic ular actio n on an or der create d by this  dialog.  I f
  30767   "^DD",101. 41,101.412 ,9,21,3,0)
  30768   this strin g contains  "R", this  prompt wi ll be aske d when ren ewing an o rder;
  30769   "^DD",101. 41,101.412 ,9,21,4,0)
  30770   if this st ring conta ins "C", t his prompt  will be a sked when  changing a n
  30771   "^DD",101. 41,101.412 ,9,21,5,0)
  30772   order; if  this strin g contains  "W", this  prompt wi ll be aske d when
  30773   "^DD",101. 41,101.412 ,9,21,6,0)
  30774   rewriting  an order.
  30775   "^DD",101. 41,101.412 ,9,"DT")
  30776   2970708
  30777   "^DD",101. 41,101.412 ,10,0)
  30778   INDEX^F^^0 ;10^K:$L(X )>25!($L(X )<1) X
  30779   "^DD",101. 41,101.412 ,10,3)
  30780   Answer mus t be 1-25  characters  in length .
  30781   "^DD",101. 41,101.412 ,10,21,0)
  30782   ^^3^3^2950 713^^^
  30783   "^DD",101. 41,101.412 ,10,21,1,0 )
  30784   For pointe r-type pro mpts, this  is the in dex to use  when sear ching the  file;
  30785   "^DD",101. 41,101.412 ,10,21,2,0 )
  30786   it must be  in the fo rm of a re gular cros s-referenc e.  To sea rch on mul tiple
  30787   "^DD",101. 41,101.412 ,10,21,3,0 )
  30788   indices, e nter a str ing of ind ex names s eparated b y semi-col ons, i.e.  "B;C".
  30789   "^DD",101. 41,101.412 ,10,"DT")
  30790   2950713
  30791   "^DD",101. 41,101.412 ,11,0)
  30792   HELP MESSA GE^F^^1;1^ K:$L(X)>16 0!($L(X)<1 ) X
  30793   "^DD",101. 41,101.412 ,11,3)
  30794   Answer mus t be 1-160  character s in lengt h.
  30795   "^DD",101. 41,101.412 ,11,21,0)
  30796   ^^2^2^2970 609^^
  30797   "^DD",101. 41,101.412 ,11,21,1,0 )
  30798   This field  contains  the help m essage to  be present ed when th e user ent ers
  30799   "^DD",101. 41,101.412 ,11,21,2,0 )
  30800   a question  mark at t his prompt .
  30801   "^DD",101. 41,101.412 ,11,"DT")
  30802   2970609
  30803   "^DD",101. 41,101.412 ,12,0)
  30804   SPECIAL LO OKUP ROUTI NE^F^^1;2^ K:$L(X)>20 !($L(X)<3)  X
  30805   "^DD",101. 41,101.412 ,12,3)
  30806   Enter the  routine to  use inste ad of DIC  to do this  lookup, a s [TAG;]RO UTINE
  30807   "^DD",101. 41,101.412 ,12,21,0)
  30808   ^^3^3^2970 609^
  30809   "^DD",101. 41,101.412 ,12,21,1,0 )
  30810   This field  contains  a routine  to execute  that will  replace t he standar d
  30811   "^DD",101. 41,101.412 ,12,21,2,0 )
  30812   DIC lookup  for this  prompt; it  must be e ntered her e as LINET AG;ROUTINE
  30813   "^DD",101. 41,101.412 ,12,21,3,0 )
  30814   using a ;  instead of  ^ and whe re LINETAG  is option al.
  30815   "^DD",101. 41,101.412 ,12,"DT")
  30816   2970609
  30817   "^DD",101. 41,101.412 ,13,0)
  30818   ASK ON CON DITION^K^^ 3;E1,245^K :$L(X)>245  X D:$D(X)  ^DIM
  30819   "^DD",101. 41,101.412 ,13,3)
  30820   This is MU MPS code t hat sets $ T to deter mine if th is prompt  should be  asked, or  given a de fault valu e and bypa ssed.
  30821   "^DD",101. 41,101.412 ,13,9)
  30822   @
  30823   "^DD",101. 41,101.412 ,13,21,0)
  30824   ^^5^5^2950 407^
  30825   "^DD",101. 41,101.412 ,13,21,1,0 )
  30826   This is MU MPS code t hat sets $ T to deter mine if th is prompt  should be  asked
  30827   "^DD",101. 41,101.412 ,13,21,2,0 )
  30828   or simply  given a de fault valu e and pres ented to t he user fo r acceptan ce
  30829   "^DD",101. 41,101.412 ,13,21,3,0 )
  30830   or editing .  For exa mple, the  prompt "Pr egnant: "  may have c ode here t o
  30831   "^DD",101. 41,101.412 ,13,21,4,0 )
  30832   check the  sex of the  current p atient, i. e. I ORSEX ="F" will  allow it t o be
  30833   "^DD",101. 41,101.412 ,13,21,5,0 )
  30834   asked only  for femal e patients .
  30835   "^DD",101. 41,101.412 ,13,"DT")
  30836   2950407
  30837   "^DD",101. 41,101.412 ,14,0)
  30838   SCREEN^K^^ 4;E1,245^K :$L(X)>245  X D:$D(X)  ^DIM
  30839   "^DD",101. 41,101.412 ,14,3)
  30840   This is St andard MUM PS code.
  30841   "^DD",101. 41,101.412 ,14,9)
  30842   @
  30843   "^DD",101. 41,101.412 ,14,21,0)
  30844   ^^2^2^2950 407^
  30845   "^DD",101. 41,101.412 ,14,21,1,0 )
  30846   For pointe r-type pro mpts, this  field may  contain M UMPS code  that will  be
  30847   "^DD",101. 41,101.412 ,14,21,2,0 )
  30848   set into D IC("S") to  screen th e possible  choices i n the poin ted-to fil e.
  30849   "^DD",101. 41,101.412 ,14,"DT")
  30850   2950407
  30851   "^DD",101. 41,101.412 ,15,0)
  30852   POST-SELEC TION ACTIO N^K^^5;E1, 245^K:$L(X )>245 X D: $D(X) ^DIM
  30853   "^DD",101. 41,101.412 ,15,3)
  30854   This is St andard MUM PS code.
  30855   "^DD",101. 41,101.412 ,15,9)
  30856   @
  30857   "^DD",101. 41,101.412 ,15,21,0)
  30858   ^^3^3^2970 923^^^^
  30859   "^DD",101. 41,101.412 ,15,21,1,0 )
  30860   This is co de that wi ll be exec uted after  a respons e is enter ed to this
  30861   "^DD",101. 41,101.412 ,15,21,2,0 )
  30862   prompt; if  this prom pt should  be re-aske d, kill th e variable  DONE.
  30863   "^DD",101. 41,101.412 ,15,21,3,0 )
  30864   If executi on of the  ordering d ialog shou ld be stop ped, set O RQUIT=1.
  30865   "^DD",101. 41,101.412 ,15,"DT")
  30866   2970923
  30867   "^DD",101. 41,101.412 ,16,0)
  30868   XECUTABLE  HELP^K^^6; E1,245^K:$ L(X)>245 X  D:$D(X) ^ DIM
  30869   "^DD",101. 41,101.412 ,16,3)
  30870   This is St andard MUM PS code.
  30871   "^DD",101. 41,101.412 ,16,9)
  30872   @
  30873   "^DD",101. 41,101.412 ,16,21,0)
  30874   ^^2^2^2950 407^
  30875   "^DD",101. 41,101.412 ,16,21,1,0 )
  30876   This is co de that is  to be exe cuted when  the user  enters two  or more
  30877   "^DD",101. 41,101.412 ,16,21,2,0 )
  30878   question m arks at th is prompt.
  30879   "^DD",101. 41,101.412 ,16,"DT")
  30880   2950407
  30881   "^DD",101. 41,101.412 ,17,0)
  30882   DEFAULT^K^ ^7;E1,245^ K:$L(X)>24 5 X D:$D(X ) ^DIM
  30883   "^DD",101. 41,101.412 ,17,3)
  30884   This is St andard MUM PS code.
  30885   "^DD",101. 41,101.412 ,17,9)
  30886   @
  30887   "^DD",101. 41,101.412 ,17,21,0)
  30888   ^^2^2^2971 219^^^^
  30889   "^DD",101. 41,101.412 ,17,21,1,0 )
  30890   This is co de that is  to be exe cuted to d etermine t he appropr iate defau lt
  30891   "^DD",101. 41,101.412 ,17,21,2,0 )
  30892   value for  this promp t, setting  Y=interna l form of  this value .
  30893   "^DD",101. 41,101.412 ,17,"DT")
  30894   2950519
  30895   "^DD",101. 41,101.412 ,18,0)
  30896   DEFAULT WO RD-PROCESS ING TEXT^1 01.41218^^ 8;0
  30897   "^DD",101. 41,101.412 ,18,21,0)
  30898   ^^1^1^2971 219^
  30899   "^DD",101. 41,101.412 ,18,21,1,0 )
  30900   This is de fault text  to be stu ffed into  this word- processing  prompt.
  30901   "^DD",101. 41,101.412 ,19,0)
  30902   ENTRY ACTI ON^K^^9;E1 ,245^K:$L( X)>245 X D :$D(X) ^DI M
  30903   "^DD",101. 41,101.412 ,19,3)
  30904   This is St andard MUM PS code.
  30905   "^DD",101. 41,101.412 ,19,9)
  30906   @
  30907   "^DD",101. 41,101.412 ,19,21,0)
  30908   ^^3^3^2970 609^
  30909   "^DD",101. 41,101.412 ,19,21,1,0 )
  30910   This is co de that wi ll be exec uted at th e beginnin g of the p rocessing  of
  30911   "^DD",101. 41,101.412 ,19,21,2,0 )
  30912   this promp t, before  the Defaul t and Ask  on Conditi on fields  are execut ed;
  30913   "^DD",101. 41,101.412 ,19,21,3,0 )
  30914   any specia l setup re quired for  this fiel d should b e done her e.
  30915   "^DD",101. 41,101.412 ,19,"DT")
  30916   2970609
  30917   "^DD",101. 41,101.412 ,20,0)
  30918   EXIT ACTIO N^K^^10;E1 ,245^K:$L( X)>245 X D :$D(X) ^DI M
  30919   "^DD",101. 41,101.412 ,20,3)
  30920   This is St andard MUM PS code.
  30921   "^DD",101. 41,101.412 ,20,9)
  30922   @
  30923   "^DD",101. 41,101.412 ,20,21,0)
  30924   ^^3^3^2970 609^
  30925   "^DD",101. 41,101.412 ,20,21,1,0 )
  30926   This is co de that wi ll be exec uted at th e very end  of the pr ocessing o f
  30927   "^DD",101. 41,101.412 ,20,21,2,0 )
  30928   this promp t, after p rompting a nd the Val idation fi eld is exe cuted;
  30929   "^DD",101. 41,101.412 ,20,21,3,0 )
  30930   any specia l cleanup  should be  done here.
  30931   "^DD",101. 41,101.412 ,20,"DT")
  30932   2970609
  30933   "^DD",101. 41,101.412 ,21,0)
  30934   ORDER TEXT  SEQUENCE^ NJ5,2^^2;1 ^K:+X'=X!( X>99.99)!( X<1)!(X?.E 1"."3N.N)  X
  30935   "^DD",101. 41,101.412 ,21,1,0)
  30936   ^.1
  30937   "^DD",101. 41,101.412 ,21,1,1,0)
  30938   101.412^AT XT
  30939   "^DD",101. 41,101.412 ,21,1,1,1)
  30940   S ^ORD(101 .41,DA(1), 10,"ATXT", $E(X,1,30) ,DA)=""
  30941   "^DD",101. 41,101.412 ,21,1,1,2)
  30942   K ^ORD(101 .41,DA(1), 10,"ATXT", $E(X,1,30) ,DA)
  30943   "^DD",101. 41,101.412 ,21,1,1,"% D",0)
  30944   ^^1^1^2960 226^
  30945   "^DD",101. 41,101.412 ,21,1,1,"% D",1,0)
  30946   Used to bu ild order  text.
  30947   "^DD",101. 41,101.412 ,21,1,1,"D T")
  30948   2960226
  30949   "^DD",101. 41,101.412 ,21,3)
  30950   Enter the  order in w hich this  value shou ld be adde d to the o rder text,  as a numb er between  1 and 99. 99; leave  this field  blank to  prevent th is value f rom being  included
  30951   "^DD",101. 41,101.412 ,21,21,0)
  30952   ^^3^3^2970 607^^^
  30953   "^DD",101. 41,101.412 ,21,21,1,0 )
  30954   This field  indicates  the order  in which  values wil l be conca tenated
  30955   "^DD",101. 41,101.412 ,21,21,2,0 )
  30956   together t o build th e order te xt; this m ay differ  from the p rompting
  30957   "^DD",101. 41,101.412 ,21,21,3,0 )
  30958   order defi ned in the  .01 Seque nce field.
  30959   "^DD",101. 41,101.412 ,21,"DT")
  30960   2960226
  30961   "^DD",101. 41,101.412 ,22,0)
  30962   FORMAT^F^^ 2;2^K:$L(X )>10!($L(X )<1) X
  30963   "^DD",101. 41,101.412 ,22,3)
  30964   Answer mus t be 1-10  characters  in length .
  30965   "^DD",101. 41,101.412 ,22,21,0)
  30966   ^^15^15^29 71207^^^^
  30967   "^DD",101. 41,101.412 ,22,21,1,0 )
  30968   This is a  string of  characters  that will  define an y exceptio ns to how
  30969   "^DD",101. 41,101.412 ,22,21,2,0 )
  30970   the extern al form of  this valu e is gener ated.  Pos sible valu es include :
  30971   "^DD",101. 41,101.412 ,22,21,3,0 )
  30972     Pointer          ->  <field #> ~<piece in  RPC list  of field # >, default  =.01
  30973   "^DD",101. 41,101.412 ,22,21,4,0 )
  30974     Set of C odes    ->  1~<piece  in RPC lis t of code>  to use co de for nam e
  30975   "^DD",101. 41,101.412 ,22,21,5,0 )
  30976     Date/Tim e       ->  Format st ring to pa ss $$FMTE^ XLFDT (def ault = 2)
  30977   "^DD",101. 41,101.412 ,22,21,6,0 )
  30978     
  30979   "^DD",101. 41,101.412 ,22,21,7,0 )
  30980     Suppress  value  ->  @
  30981   "^DD",101. 41,101.412 ,22,21,8,0 )
  30982     Replace  value   ->  @<ptr> wh ere ptr is  the Dialo g IEN of t he prompt
  30983   "^DD",101. 41,101.412 ,22,21,9,0 )
  30984                           whose va lue, when  present, s upersedes  this value
  30985   "^DD",101. 41,101.412 ,22,21,10, 0)
  30986     Required  value  ->  *<ptr> wh ere ptr is  the Dialo g IEN of t he prompt
  30987   "^DD",101. 41,101.412 ,22,21,11, 0)
  30988                           whose va lue is req uired to b e present  to include
  30989   "^DD",101. 41,101.412 ,22,21,12, 0)
  30990                           this val ue
  30991   "^DD",101. 41,101.412 ,22,21,13, 0)
  30992     Ignore i f same  ->  =<ptr> wh ere ptr is  the Dialo g IEN of t he prompt
  30993   "^DD",101. 41,101.412 ,22,21,14, 0)
  30994                           whose va lue, if th e external  form is t he same,
  30995   "^DD",101. 41,101.412 ,22,21,15, 0)
  30996                           supersed es this va lue
  30997   "^DD",101. 41,101.412 ,22,"DT")
  30998   2960226
  30999   "^DD",101. 41,101.412 ,23,0)
  31000   OMIT TEXT^ F^^2;3^K:$ L(X)>30!($ L(X)<1) X
  31001   "^DD",101. 41,101.412 ,23,3)
  31002   Answer mus t be 1-30  characters  in length .
  31003   "^DD",101. 41,101.412 ,23,21,0)
  31004   ^^3^3^2970 829^^^^
  31005   "^DD",101. 41,101.412 ,23,21,1,0 )
  31006   This is th e external  form of a  value tha t is not t o be inclu ded when b uilding
  31007   "^DD",101. 41,101.412 ,23,21,2,0 )
  31008   the order  text.  E.g . to inclu de the urg ency in th e order te xt unless  it
  31009   "^DD",101. 41,101.412 ,23,21,3,0 )
  31010   is routine , enter "R OUTINE" he re.
  31011   "^DD",101. 41,101.412 ,23,"DT")
  31012   2970829
  31013   "^DD",101. 41,101.412 ,24,0)
  31014   LEADING TE XT^F^^2;4^ K:$L(X)>80 !($L(X)<1)  X
  31015   "^DD",101. 41,101.412 ,24,3)
  31016   Answer mus t be 1-80  characters  in length .
  31017   "^DD",101. 41,101.412 ,24,21,0)
  31018   ^^3^3^2970 724^^^^
  31019   "^DD",101. 41,101.412 ,24,21,1,0 )
  31020   This field  contains  text that  will be ap pended to  the order  text
  31021   "^DD",101. 41,101.412 ,24,21,2,0 )
  31022   immediatel y in front  of this v alue, e.g.  "Instruct ions:".  I f this tex t
  31023   "^DD",101. 41,101.412 ,24,21,3,0 )
  31024   is contain ed in a va riable, en ter @NAME  where NAME  is the va riable nam e.
  31025   "^DD",101. 41,101.412 ,24,"DT")
  31026   2970724
  31027   "^DD",101. 41,101.412 ,25,0)
  31028   TRAILING T EXT^F^^2;5 ^K:$L(X)>8 0!($L(X)<1 ) X
  31029   "^DD",101. 41,101.412 ,25,3)
  31030   Answer mus t be 1-80  characters  in length .
  31031   "^DD",101. 41,101.412 ,25,21,0)
  31032   ^^3^3^2970 724^^^^
  31033   "^DD",101. 41,101.412 ,25,21,1,0 )
  31034   This field  contains  text that  will be ap pended to  the order  text
  31035   "^DD",101. 41,101.412 ,25,21,2,0 )
  31036   immediatel y followin g this val ue, e.g. " refills".   If this t ext is
  31037   "^DD",101. 41,101.412 ,25,21,3,0 )
  31038   contained  in a varia ble, enter  @NAME whe re NAME is  the varia ble name.
  31039   "^DD",101. 41,101.412 ,25,"DT")
  31040   2970724
  31041   "^DD",101. 41,101.412 ,26,0)
  31042   START NEW  LINE^S^1:Y ES;0:NO;^2 ;6^Q
  31043   "^DD",101. 41,101.412 ,26,3)
  31044   Enter YES  if this va lue should  begin on  a new line  in the or der text.
  31045   "^DD",101. 41,101.412 ,26,21,0)
  31046   0^^2^2^297 0911^
  31047   "^DD",101. 41,101.412 ,26,21,1,0 )
  31048   This field  determine s if this  value is c oncatenate d onto the  current l ine
  31049   "^DD",101. 41,101.412 ,26,21,2,0 )
  31050   when build ing the or der text,  or if a ne w line is  started wi th this va lue.
  31051   "^DD",101. 41,101.412 ,26,"DT")
  31052   2970911
  31053   "^DD",101. 41,101.412 ,27,0)
  31054   WORD-WRAP^ S^1:DON'T  WRAP;0:WRA P;^2;7^Q
  31055   "^DD",101. 41,101.412 ,27,3)
  31056   Enter 'Don 't Wrap' t o have the  text be a dded line- by-line as  it is sto red; the d efault for matting is  'Wrap'.
  31057   "^DD",101. 41,101.412 ,27,21,0)
  31058   ^^3^3^2970 926^^^
  31059   "^DD",101. 41,101.412 ,27,21,1,0 )
  31060   This field  determine s if this  text shoul d be wrapp ed when ad ded to the
  31061   "^DD",101. 41,101.412 ,27,21,2,0 )
  31062   order text , or appen ded line b y line as  stored in  the file;  this is on ly
  31063   "^DD",101. 41,101.412 ,27,21,3,0 )
  31064   used for w ord-proces sing type  prompts.
  31065   "^DD",101. 41,101.412 ,27,"DT")
  31066   2970926
  31067   "^DD",101. 41,101.412 ,101,0)
  31068   WINDOWS CO NTROL^F^^W ;1^K:$L(X) >30!($L(X) <1) X
  31069   "^DD",101. 41,101.412 ,101,3)
  31070   Answer mus t be 1-30  characters  in length .
  31071   "^DD",101. 41,101.412 ,101,21,0)
  31072   ^^2^2^2950 715^
  31073   "^DD",101. 41,101.412 ,101,21,1, 0)
  31074   Stores the  type of W indows con trol neces sary to ge t the data  for this
  31075   "^DD",101. 41,101.412 ,101,21,2, 0)
  31076   prompt.
  31077   "^DD",101. 41,101.412 ,101,"DT")
  31078   2960517
  31079   "^DD",101. 41,101.412 ,102,0)
  31080   API NAME^F ^^W;2^K:$L (X)>30!($L (X)<1) X
  31081   "^DD",101. 41,101.412 ,102,3)
  31082   Answer mus t be 1-30  characters  in length .
  31083   "^DD",101. 41,101.412 ,102,21,0)
  31084   ^^3^3^2950 715^
  31085   "^DD",101. 41,101.412 ,102,21,1, 0)
  31086   This is th e API that  should be  called wh en the con trol is us ed.  How t he API
  31087   "^DD",101. 41,101.412 ,102,21,2, 0)
  31088   is used va rys with t he control .  Example s are: fil ling list  boxes, get ting
  31089   "^DD",101. 41,101.412 ,102,21,3, 0)
  31090   boilerplat e text, et c.
  31091   "^DD",101. 41,101.412 ,102,"DT")
  31092   2951002
  31093   "^DD",101. 41,101.412 ,103,0)
  31094   API PARAME TER #1^F^^ W;3^K:$L(X )>30!($L(X )<1) X
  31095   "^DD",101. 41,101.412 ,103,3)
  31096   Answer mus t be 1-30  characters  in length .
  31097   "^DD",101. 41,101.412 ,103,21,0)
  31098   ^^1^1^2950 715^
  31099   "^DD",101. 41,101.412 ,103,21,1, 0)
  31100   A paramete r that is  used by th e API call  may be st ored here.
  31101   "^DD",101. 41,101.412 ,103,"DT")
  31102   2950715
  31103   "^DD",101. 41,101.412 ,113,0)
  31104   WINDOWS CO NDITION^K^ ^W3;E1,245 ^K:$L(X)>2 45 X D:$D( X) ^DIM
  31105   "^DD",101. 41,101.412 ,113,3)
  31106   This is St andard MUM PS code.
  31107   "^DD",101. 41,101.412 ,113,9)
  31108   @
  31109   "^DD",101. 41,101.412 ,113,21,0)
  31110   ^^3^3^2950 715^
  31111   "^DD",101. 41,101.412 ,113,21,1, 0)
  31112   This is si lent code  that is ex ecuted whe n building  the dialo g for wind ows.
  31113   "^DD",101. 41,101.412 ,113,21,2, 0)
  31114   It identif ies which  prompts sh ould be in cluded in  the dialog .  The con dition
  31115   "^DD",101. 41,101.412 ,113,21,3, 0)
  31116   should lea ve $T fals e if the p rompt shou ld not be  asked.
  31117   "^DD",101. 41,101.412 ,113,"DT")
  31118   2950715
  31119   "^DD",101. 41,101.412 ,117,0)
  31120   WINDOWS DE FAULT^K^^W 7;E1,245^K :$L(X)>245  X D:$D(X)  ^DIM
  31121   "^DD",101. 41,101.412 ,117,3)
  31122   This is St andard MUM PS code.
  31123   "^DD",101. 41,101.412 ,117,9)
  31124   @
  31125   "^DD",101. 41,101.412 ,117,21,0)
  31126   ^^2^2^2950 715^
  31127   "^DD",101. 41,101.412 ,117,21,1, 0)
  31128   This code  should sil ently set  the defaul t value of  a prompt  when it is  
  31129   "^DD",101. 41,101.412 ,117,21,2, 0)
  31130   selected.
  31131   "^DD",101. 41,101.412 ,117,"DT")
  31132   2950715
  31133   "^DD",101. 41,101.412 18,0)
  31134   DEFAULT WO RD-PROCESS ING TEXT S UB-FIELD^^ .01^1
  31135   "^DD",101. 41,101.412 18,0,"DT")
  31136   2950407
  31137   "^DD",101. 41,101.412 18,0,"NM", "DEFAULT W ORD-PROCES SING TEXT" )
  31138  
  31139   "^DD",101. 41,101.412 18,0,"UP")
  31140   101.412
  31141   "^DD",101. 41,101.412 18,.01,0)
  31142   DEFAULT WO RD-PROCESS ING TEXT^W ^^0;1^Q
  31143   "^DD",101. 41,101.412 18,.01,3)
  31144   Enter the  default re sponse for  a word-pr ocessing t ype prompt .
  31145   "^DD",101. 41,101.412 18,.01,21, 0)
  31146   ^^2^2^2950 407^
  31147   "^DD",101. 41,101.412 18,.01,21, 1,0)
  31148   This field  contains  the text t o be prese nted as th e default  for this p rompt,
  31149   "^DD",101. 41,101.412 18,.01,21, 2,0)
  31150   for word-p rocessing  type promp ts.
  31151   "^DD",101. 41,101.412 18,.01,"DT ")
  31152   2950407
  31153   "^DD",101. 41,101.415 ,0)
  31154   CONTROLS S UB-FIELD^^ 14^14
  31155   "^DD",101. 41,101.415 ,0,"DT")
  31156   2960202
  31157   "^DD",101. 41,101.415 ,0,"IX","A C",101.415 ,3)
  31158  
  31159   "^DD",101. 41,101.415 ,0,"IX","B ",101.415, .01)
  31160  
  31161   "^DD",101. 41,101.415 ,0,"NM","C ONTROLS")
  31162  
  31163   "^DD",101. 41,101.415 ,0,"UP")
  31164   101.41
  31165   "^DD",101. 41,101.415 ,.01,0)
  31166   LOGICAL NA ME^MF^^0;1 ^K:$L(X)>8 !($L(X)<1) !'(X?1.8U)  X
  31167   "^DD",101. 41,101.415 ,.01,1,0)
  31168   ^.1
  31169   "^DD",101. 41,101.415 ,.01,1,1,0 )
  31170   101.415^B
  31171   "^DD",101. 41,101.415 ,.01,1,1,1 )
  31172   S ^ORD(101 .41,DA(1), 50,"B",$E( X,1,30),DA )=""
  31173   "^DD",101. 41,101.415 ,.01,1,1,2 )
  31174   K ^ORD(101 .41,DA(1), 50,"B",$E( X,1,30),DA )
  31175   "^DD",101. 41,101.415 ,.01,3)
  31176   Answer mus t be 1-8 c haracters  in length.
  31177   "^DD",101. 41,101.415 ,.01,21,0)
  31178   ^^1^1^2960 202^
  31179   "^DD",101. 41,101.415 ,.01,21,1, 0)
  31180   This is th e name by  which cont rols can r efer to ea ch other.
  31181   "^DD",101. 41,101.415 ,.01,"DT")
  31182   2960202
  31183   "^DD",101. 41,101.415 ,2,0)
  31184   ITEM^P101. 41'^ORD(10 1.41,^0;2^ Q
  31185   "^DD",101. 41,101.415 ,2,"DT")
  31186   2960202
  31187   "^DD",101. 41,101.415 ,3,0)
  31188   CREATE SEQ UENCE^NJ2, 0^^0;3^K:+ X'=X!(X>99 )!(X<1)!(X ?.E1"."1N. N) X
  31189   "^DD",101. 41,101.415 ,3,1,0)
  31190   ^.1
  31191   "^DD",101. 41,101.415 ,3,1,1,0)
  31192   101.415^AC
  31193   "^DD",101. 41,101.415 ,3,1,1,1)
  31194   S ^ORD(101 .41,DA(1), 50,"AC",$E (X,1,30),D A)=""
  31195   "^DD",101. 41,101.415 ,3,1,1,2)
  31196   K ^ORD(101 .41,DA(1), 50,"AC",$E (X,1,30),D A)
  31197   "^DD",101. 41,101.415 ,3,1,1,"%D ",0)
  31198   ^^2^2^2960 202^
  31199   "^DD",101. 41,101.415 ,3,1,1,"%D ",1,0)
  31200   The 'AC' c ross-refer ence puts  in window  controls i n order by  creation 
  31201   "^DD",101. 41,101.415 ,3,1,1,"%D ",2,0)
  31202   sequence.
  31203   "^DD",101. 41,101.415 ,3,1,1,"DT ")
  31204   2960202
  31205   "^DD",101. 41,101.415 ,3,3)
  31206   Type a Num ber betwee n 1 and 99 , 0 Decima l Digits
  31207   "^DD",101. 41,101.415 ,3,"DT")
  31208   2960202
  31209   "^DD",101. 41,101.415 ,4,0)
  31210   CONTROL TY PE^S^0:Lab el;1:Butto n;2:Edit;3 :Memo;4:Li stBox;5:Si mpleCombo; 6:DropDown List;7:Lon gCombo;^0; 4^Q
  31211   "^DD",101. 41,101.415 ,4,"DT")
  31212   2960202
  31213   "^DD",101. 41,101.415 ,5,0)
  31214   LABEL^F^^0 ;5^K:$L(X) >30!($L(X) <1) X
  31215   "^DD",101. 41,101.415 ,5,3)
  31216   Answer mus t be 1-30  characters  in length .
  31217   "^DD",101. 41,101.415 ,5,"DT")
  31218   2960202
  31219   "^DD",101. 41,101.415 ,6,0)
  31220   BESIDE^F^^ 0;6^K:$L(X )>8!($L(X) <1) X
  31221   "^DD",101. 41,101.415 ,6,3)
  31222   Answer mus t be 1-8 c haracters  in length.
  31223   "^DD",101. 41,101.415 ,6,"DT")
  31224   2960202
  31225   "^DD",101. 41,101.415 ,7,0)
  31226   BELOW^F^^0 ;7^K:$L(X) >8!($L(X)< 1) X
  31227   "^DD",101. 41,101.415 ,7,3)
  31228   Answer mus t be 1-8 c haracters  in length.
  31229   "^DD",101. 41,101.415 ,7,"DT")
  31230   2960202
  31231   "^DD",101. 41,101.415 ,8,0)
  31232   WIDTH^NJ6, 4^^0;8^K:+ X'=X!(X>1) !(X<0)!(X? .E1"."5N.N ) X
  31233   "^DD",101. 41,101.415 ,8,3)
  31234   Type a Num ber betwee n 0 and 1,  4 Decimal  Digits
  31235   "^DD",101. 41,101.415 ,8,"DT")
  31236   2960202
  31237   "^DD",101. 41,101.415 ,9,0)
  31238   LEFT CONTR OL^F^^0;9^ K:$L(X)>8! ($L(X)<1)  X
  31239   "^DD",101. 41,101.415 ,9,3)
  31240   Answer mus t be 1-8 c haracters  in length.
  31241   "^DD",101. 41,101.415 ,9,"DT")
  31242   2960202
  31243   "^DD",101. 41,101.415 ,10,0)
  31244   RIGHT CONT ROL^F^^0;1 0^K:$L(X)> 8!($L(X)<1 ) X
  31245   "^DD",101. 41,101.415 ,10,3)
  31246   Answer mus t be 1-8 c haracters  in length.
  31247   "^DD",101. 41,101.415 ,10,"DT")
  31248   2960202
  31249   "^DD",101. 41,101.415 ,11,0)
  31250   HEIGHT^NJ2 ,0^^0;11^K :+X'=X!(X> 15)!(X<1)! (X?.E1"."1 N.N) X
  31251   "^DD",101. 41,101.415 ,11,3)
  31252   Type a Num ber betwee n 1 and 15 , 0 Decima l Digits
  31253   "^DD",101. 41,101.415 ,11,"DT")
  31254   2960202
  31255   "^DD",101. 41,101.415 ,12,0)
  31256   UPPER CONT ROL^F^^0;1 2^K:$L(X)> 8!($L(X)<1 ) X
  31257   "^DD",101. 41,101.415 ,12,3)
  31258   Answer mus t be 1-8 c haracters  in length.
  31259   "^DD",101. 41,101.415 ,12,"DT")
  31260   2960202
  31261   "^DD",101. 41,101.415 ,13,0)
  31262   LOWER CONT ROL^F^^0;1 3^K:$L(X)> 8!($L(X)<1 ) X
  31263   "^DD",101. 41,101.415 ,13,3)
  31264   Answer mus t be 1-8 c haracters  in length.
  31265   "^DD",101. 41,101.415 ,13,"DT")
  31266   2960202
  31267   "^DD",101. 41,101.415 ,14,0)
  31268   TAB SEQUEN CE^NJ2,0^^ 0;14^K:+X' =X!(X>89)! (X<0)!(X?. E1"."1N.N)  X
  31269   "^DD",101. 41,101.415 ,14,3)
  31270   Type a Num ber betwee n 0 and 89 , 0 Decima l Digits
  31271   "^DD",101. 41,101.415 ,14,"DT")
  31272   2960202
  31273   "^DD",101. 41,101.416 ,0)
  31274   RESPONSES  SUB-FIELD^ ^2^5
  31275   "^DD",101. 41,101.416 ,0,"DT")
  31276   2960717
  31277   "^DD",101. 41,101.416 ,0,"IX","D ",101.416, .02)
  31278  
  31279   "^DD",101. 41,101.416 ,0,"NM","R ESPONSES")
  31280  
  31281   "^DD",101. 41,101.416 ,0,"UP")
  31282   101.41
  31283   "^DD",101. 41,101.416 ,.01,0)
  31284   ITEM ENTRY ^MNJ7,0^^0 ;1^K:+X'=X !(X>999999 9)!(X<1)!( X?.E1"."1N .N) X
  31285   "^DD",101. 41,101.416 ,.01,1,0)
  31286   ^.1^^0
  31287   "^DD",101. 41,101.416 ,.01,3)
  31288   Type a Num ber betwee n 1 and 99 99999, 0 D ecimal Dig its
  31289   "^DD",101. 41,101.416 ,.01,21,0)
  31290   ^^2^2^2971 219^^^
  31291   "^DD",101. 41,101.416 ,.01,21,1, 0)
  31292   This is th e internal  entry num ber of the  prompt in  the Item  multiple
  31293   "^DD",101. 41,101.416 ,.01,21,2, 0)
  31294   by which t his respon se was obt ained.
  31295   "^DD",101. 41,101.416 ,.01,"DT")
  31296   2961118
  31297   "^DD",101. 41,101.416 ,.02,0)
  31298   DIALOG^P10 1.41'^ORD( 101.41,^0; 2^Q
  31299   "^DD",101. 41,101.416 ,.02,1,0)
  31300   ^.1
  31301   "^DD",101. 41,101.416 ,.02,1,1,0 )
  31302   101.416^D
  31303   "^DD",101. 41,101.416 ,.02,1,1,1 )
  31304   S ^ORD(101 .41,DA(1), 6,"D",$E(X ,1,30),DA) =""
  31305   "^DD",101. 41,101.416 ,.02,1,1,2 )
  31306   K ^ORD(101 .41,DA(1), 6,"D",$E(X ,1,30),DA)
  31307   "^DD",101. 41,101.416 ,.02,1,1," DT")
  31308   2961118
  31309   "^DD",101. 41,101.416 ,.02,3)
  31310   Select the  dialog pr ompt from  which this  response  was genera ted.
  31311   "^DD",101. 41,101.416 ,.02,21,0)
  31312   ^^2^2^2960 717^
  31313   "^DD",101. 41,101.416 ,.02,21,1, 0)
  31314   This is a  pointer to  the dialo g prompt,  which is i n the Orde r Dialog f ile
  31315   "^DD",101. 41,101.416 ,.02,21,2, 0)
  31316   as type pr ompt.
  31317   "^DD",101. 41,101.416 ,.02,"DT")
  31318   2961118
  31319   "^DD",101. 41,101.416 ,.03,0)
  31320   INSTANCE^N J7,0^^0;3^ K:+X'=X!(X >9999999)! (X<1)!(X?. E1"."1N.N)  X
  31321   "^DD",101. 41,101.416 ,.03,3)
  31322   Type a Num ber betwee n 1 and 99 99999, 0 D ecimal Dig its
  31323   "^DD",101. 41,101.416 ,.03,21,0)
  31324   ^^2^2^2960 717^
  31325   "^DD",101. 41,101.416 ,.03,21,1, 0)
  31326   In the cas e of multi ple answer s for the  same item,  this iden tifies the
  31327   "^DD",101. 41,101.416 ,.03,21,2, 0)
  31328   individual  instance.
  31329   "^DD",101. 41,101.416 ,.03,"DT")
  31330   2960717
  31331   "^DD",101. 41,101.416 ,1,0)
  31332   VALUE^FO^^ 1;1^K:$L(X )>245!($L( X)<1) X
  31333   "^DD",101. 41,101.416 ,1,2)
  31334   S Y(0)=Y S  Y=$$OUTPU T^ORCMEDT5 (Y)
  31335   "^DD",101. 41,101.416 ,1,2.1)
  31336   S Y=$$OUTP UT^ORCMEDT 5(Y)
  31337   "^DD",101. 41,101.416 ,1,3)
  31338   Answer mus t be 1-245  character s in lengt h.
  31339   "^DD",101. 41,101.416 ,1,21,0)
  31340   ^^2^2^2971 219^^
  31341   "^DD",101. 41,101.416 ,1,21,1,0)
  31342   This conta ins the ac tual respo nse, unles s the valu e is a wor d processi ng
  31343   "^DD",101. 41,101.416 ,1,21,2,0)
  31344   type.
  31345   "^DD",101. 41,101.416 ,1,"DT")
  31346   2980717
  31347   "^DD",101. 41,101.416 ,2,0)
  31348   TEXT^101.4 162^^2;0
  31349   "^DD",101. 41,101.416 ,2,21,0)
  31350   ^^1^1^2971 219^
  31351   "^DD",101. 41,101.416 ,2,21,1,0)
  31352   This conta ins the ac tual respo nse, for w ord-proces sing type  prompts.
  31353   "^DD",101. 41,101.416 ,2,"DT")
  31354   2960717
  31355   "^DD",101. 41,101.416 2,0)
  31356   TEXT SUB-F IELD^^.01^ 1
  31357   "^DD",101. 41,101.416 2,0,"DT")
  31358   2960717
  31359   "^DD",101. 41,101.416 2,0,"NM"," TEXT")
  31360  
  31361   "^DD",101. 41,101.416 2,0,"UP")
  31362   101.416
  31363   "^DD",101. 41,101.416 2,.01,0)
  31364   TEXT^WL^^0 ;1^Q
  31365   "^DD",101. 41,101.416 2,.01,21,0 )
  31366   ^^1^1^2960 717^^
  31367   "^DD",101. 41,101.416 2,.01,21,1 ,0)
  31368   This conta ins respon ses to ite ms that ar e a word p rocessing  type.
  31369   "^DD",101. 41,101.416 2,.01,"DT" )
  31370   2960717
  31371   "^DD",560, 560,0)
  31372   FIELD^^.04 ^7
  31373   "^DD",560, 560,0,"DT" )
  31374   3140521
  31375   "^DD",560, 560,0,"IX" ,"B",560,. 01)
  31376  
  31377   "^DD",560, 560,0,"NM" ,"VPR SUBS CRIPTION")
  31378  
  31379   "^DD",560, 560,0,"VRP K")
  31380   VPR
  31381   "^DD",560, 560,.01,0)
  31382   SERVER^RF^ ^0;1^K:$L( X)>64!($L( X)<1)!'(X' ?1P.E) X
  31383   "^DD",560, 560,.01,1, 0)
  31384   ^.1^^-1
  31385   "^DD",560, 560,.01,1, 1,0)
  31386   560^B
  31387   "^DD",560, 560,.01,1, 1,1)
  31388   S ^VPR(560 ,"B",$E(X, 1,64),DA)= ""
  31389   "^DD",560, 560,.01,1, 1,2)
  31390   K ^VPR(560 ,"B",$E(X, 1,64),DA)
  31391   "^DD",560, 560,.01,3)
  31392   Answer mus t be 1-64  characters  in length .
  31393   "^DD",560, 560,.01,21 ,0)
  31394   ^.001^1^1^ 3140212^^^ ^
  31395   "^DD",560, 560,.01,21 ,1,0)
  31396   This is th e name of  the client  system th at is subs cribing to  data upda tes.
  31397   "^DD",560, 560,.01,"D T")
  31398   3120522
  31399   "^DD",560, 560,.02,0)
  31400   LASTUPDATE ^F^^0;2^K: $L(X)>100! ($L(X)<3)  X
  31401   "^DD",560, 560,.02,3)
  31402   Answer mus t be 3-100  character s in lengt h. (Do not  modified)
  31403   "^DD",560, 560,.02,21 ,0)
  31404   ^^3^3^3110 908^
  31405   "^DD",560, 560,.02,21 ,1,0)
  31406   This field  holds a f lag, indic ating if t his URL sh ould be no tified via  the
  31407   "^DD",560, 560,.02,21 ,2,0)
  31408   nightly sc heduled op tion VPR A PPOINTMENT S of the l ist of pat ients expe cted
  31409   "^DD",560, 560,.02,21 ,3,0)
  31410   to be seen  tomorrow.
  31411   "^DD",560, 560,.02,"D T")
  31412   3140225
  31413   "^DD",560, 560,.03,0)
  31414   OPERATION  DATA^S^0:U NSUBCRIBED ;1:SUBSCRI BED;2:INIT IALIZED;^0 ;3^Q
  31415   "^DD",560, 560,.03,3)
  31416   Enter YES  if the hmp  server ha s received  a sync of  operation al data (D o Not Modi fied)
  31417   "^DD",560, 560,.03,21 ,0)
  31418   ^^2^2^3110 908^
  31419   "^DD",560, 560,.03,21 ,1,0)
  31420   This field  holds a f lag, indic ating if t his URL sh ould be no tified via  http
  31421   "^DD",560, 560,.03,21 ,2,0)
  31422   when a pat ient is ad mitted.
  31423   "^DD",560, 560,.03,"D T")
  31424   3140226
  31425   "^DD",560, 560,.04,0)
  31426   REPEAT POL LS^NJ8,0^^ 0;4^K:+X'= X!(X>99999 999)!(X<0) !(X?.E1"." 1N.N) X
  31427   "^DD",560, 560,.04,3)
  31428   Type a num ber betwee n 0 and 99 999999, 0  decimal di gits.
  31429   "^DD",560, 560,.04,21 ,0)
  31430   ^^2^2^3140 404^
  31431   "^DD",560, 560,.04,21 ,1,0)
  31432   This track s the numb er of time s the same  "last upd ate" value  has been
  31433   "^DD",560, 560,.04,21 ,2,0)
  31434   repeated.   A high re peat may b e normal i f data are  not chang ing.
  31435   "^DD",560, 560,.04,"D T")
  31436   3140404
  31437   "^DD",560, 560,.1,0)
  31438   URL^F^^.1; 1^K:$L(X)> 250!($L(X) <1) X
  31439   "^DD",560, 560,.1,3)
  31440   Answer mus t be 1-250  character s in lengt h.
  31441   "^DD",560, 560,.1,21, 0)
  31442   ^^1^1^3110 706^
  31443   "^DD",560, 560,.1,21, 1,0)
  31444   This is th e fully sp ecified UR L to call  when updat es are ava ilable.
  31445   "^DD",560, 560,.1,"DT ")
  31446   3110706
  31447   "^DD",560, 560,1,0)
  31448   PATIENT^56 0.01P^^1;0
  31449   "^DD",560, 560,1,21,0 )
  31450   ^.001^1^1^ 3140212^^^ ^
  31451   "^DD",560, 560,1,21,1 ,0)
  31452   This is a  patient th at will be  monitored  for new d ata and up dates.
  31453   "^DD",560, 560,2,0)
  31454   ROSTER^560 .02P^^2;0
  31455   "^DD",560, 560,2,21,0 )
  31456   ^.001^1^1^ 3130417^^^ ^
  31457   "^DD",560, 560,2,21,1 ,0)
  31458   This is a  roster tha t will be  monitored  for new pa tients and  updates.
  31459   "^DD",560, 560,2,"DT" )
  31460   3130417
  31461   "^DD",560, 560.01,0)
  31462   PATIENT SU B-FIELD^^3 ^3
  31463   "^DD",560, 560.01,0," DT")
  31464   3140521
  31465   "^DD",560, 560.01,0," NM","PATIE NT")
  31466  
  31467   "^DD",560, 560.01,0," UP")
  31468   560
  31469   "^DD",560, 560.01,.01 ,0)
  31470   PATIENT NA ME^MP2'X^D PT(^0;1^S  DINUM=X
  31471   "^DD",560, 560.01,.01 ,1,0)
  31472   ^.1^^0
  31473   "^DD",560, 560.01,.01 ,3)
  31474   Enter the  name of a  patient to  be tracke d.
  31475   "^DD",560, 560.01,.01 ,21,0)
  31476   ^.001^1^1^ 3140212^^
  31477   "^DD",560, 560.01,.01 ,21,1,0)
  31478   This is th e name of  the patien t being mo nitored fo r new data .
  31479   "^DD",560, 560.01,.01 ,"DT")
  31480   3140226
  31481   "^DD",560, 560.01,2,0 )
  31482   STATUS^S^0 :UNINITIAL IZED;1:INI TIALIZING; 2:INITIALI ZED;^0;2^Q
  31483   "^DD",560, 560.01,2,3 )
  31484   Tracks the  status of  a patient  sync. (Do  Not Modif y)
  31485   "^DD",560, 560.01,2,2 1,0)
  31486   ^^4^4^3140 521^
  31487   "^DD",560, 560.01,2,2 1,1,0)
  31488   This field  tracks th e initiali zation pro gress of t he patient .  When a 
  31489   "^DD",560, 560.01,2,2 1,2,0)
  31490   patient is  initially  subscribe d, they ar e added to  this mult iple.  The  
  31491   "^DD",560, 560.01,2,2 1,3,0)
  31492   statis is  "1" when t he extract s start an d "2" when  they fini sh.  At th at 
  31493   "^DD",560, 560.01,2,2 1,4,0)
  31494   point, fre shness upd ates are m oved into  the stream .
  31495   "^DD",560, 560.01,2," DT")
  31496   3140521
  31497   "^DD",560, 560.01,3,0 )
  31498   STATUS TIM E^D^^0;3^S  %DT="ESTX R" D ^%DT  S X=Y K:Y< 1 X
  31499   "^DD",560, 560.01,3,3 )
  31500   Enter the  time the s tatus chan ged.
  31501   "^DD",560, 560.01,3,2 1,0)
  31502   ^^1^1^3140 521^
  31503   "^DD",560, 560.01,3,2 1,1,0)
  31504   This is th e time of  the last c hange in e xtract sta tus.
  31505   "^DD",560, 560.01,3," DT")
  31506   3140521
  31507   "^DD",560, 560.02,0)
  31508   ROSTER SUB -FIELD^^2^ 2
  31509   "^DD",560, 560.02,0," DT")
  31510   3130417
  31511   "^DD",560, 560.02,0," NM","ROSTE R")
  31512  
  31513   "^DD",560, 560.02,0," UP")
  31514   560
  31515   "^DD",560, 560.02,.01 ,0)
  31516   NAME^MP561 .2'X^VPROS TER(^0;1^S  DINUM=X
  31517   "^DD",560, 560.02,.01 ,1,0)
  31518   ^.1^^0
  31519   "^DD",560, 560.02,.01 ,3)
  31520   Enter the  name of a  roster to  be tracked .
  31521   "^DD",560, 560.02,.01 ,21,0)
  31522   ^.001^1^1^ 3130417^^
  31523   "^DD",560, 560.02,.01 ,21,1,0)
  31524   This is th e name of  the roster  being mon itored for  new patie nts.
  31525   "^DD",560, 560.02,.01 ,"DT")
  31526   3130417
  31527   "^DD",560, 560.02,2,0 )
  31528   ON^S^1:YES ;0:NO;^0;2 ^Q
  31529   "^DD",560, 560.02,2,3 )
  31530   Enter YES  to turn on  data trac king for t his roster .
  31531   "^DD",560, 560.02,2,2 1,0)
  31532   ^.001^3^3^ 3130417^^
  31533   "^DD",560, 560.02,2,2 1,1,0)
  31534   This field  turns on  the Data M onitor for  this rost er and cli ent system .
  31535   "^DD",560, 560.02,2,2 1,2,0)
  31536   If ON=true , a new sn apshot of  this roste r will be  sent to th e client
  31537   "^DD",560, 560.02,2,2 1,3,0)
  31538   when new d ata update s are requ ested.
  31539   "^DD",560, 560.02,2," DT")
  31540   3130417
  31541   "^DD",560. 1,560.1,0)
  31542   FIELD^^1^4
  31543   "^DD",560. 1,560.1,0, "DT")
  31544   3121129
  31545   "^DD",560. 1,560.1,0, "IX","B",5 60.1,.01)
  31546  
  31547   "^DD",560. 1,560.1,0, "NM","VPR  PATIENT OB JECT")
  31548  
  31549   "^DD",560. 1,560.1,0, "VRPK")
  31550   VPR
  31551   "^DD",560. 1,560.1,.0 1,0)
  31552   UID^RF^^0; 1^K:$L(X)> 63!($L(X)< 3)!'(X'?1P .E) X
  31553   "^DD",560. 1,560.1,.0 1,1,0)
  31554   ^.1
  31555   "^DD",560. 1,560.1,.0 1,1,1,0)
  31556   560.1^B
  31557   "^DD",560. 1,560.1,.0 1,1,1,1)
  31558   S ^VPR(560 .1,"B",$E( X,1,63),DA )=""
  31559   "^DD",560. 1,560.1,.0 1,1,1,2)
  31560   K ^VPR(560 .1,"B",$E( X,1,63),DA )
  31561   "^DD",560. 1,560.1,.0 1,3)
  31562   Answer mus t be 3-63  characters  in length .
  31563   "^DD",560. 1,560.1,.0 1,21,0)
  31564   ^^1^1^3121 129^
  31565   "^DD",560. 1,560.1,.0 1,21,1,0)
  31566   The fully  specified  Universal  ID string  for this o bject.
  31567   "^DD",560. 1,560.1,.0 1,23,0)
  31568   ^^1^1^3121 129^
  31569   "^DD",560. 1,560.1,.0 1,23,1,0)
  31570   urn:va:{sy stemId}:{D FN}:{colle ction}:{ie n}
  31571   "^DD",560. 1,560.1,.0 1,"DT")
  31572   3121129
  31573   "^DD",560. 1,560.1,.0 2,0)
  31574   PATIENT^RP 2'^DPT(^0; 2^Q
  31575   "^DD",560. 1,560.1,.0 2,3)
  31576   Enter the  patient th at owns th is object.
  31577   "^DD",560. 1,560.1,.0 2,21,0)
  31578   ^^1^1^3121 129^
  31579   "^DD",560. 1,560.1,.0 2,21,1,0)
  31580   Patient fi le #2 ien
  31581   "^DD",560. 1,560.1,.0 2,"DT")
  31582   3121129
  31583   "^DD",560. 1,560.1,.0 3,0)
  31584   COLLECTION ^F^^0;3^K: $L(X)>30!( $L(X)<3) X
  31585   "^DD",560. 1,560.1,.0 3,3)
  31586   Answer mus t be 3-30  characters  in length .
  31587   "^DD",560. 1,560.1,.0 3,21,0)
  31588   ^^1^1^3121 129^
  31589   "^DD",560. 1,560.1,.0 3,21,1,0)
  31590   The name o f the type  or kind o f data thi s object b elongs to.
  31591   "^DD",560. 1,560.1,.0 3,"DT")
  31592   3121129
  31593   "^DD",560. 1,560.1,1, 0)
  31594   DATA^560.1 01^^1;0
  31595   "^DD",560. 1,560.101, 0)
  31596   DATA SUB-F IELD^^.01^ 1
  31597   "^DD",560. 1,560.101, 0,"DT")
  31598   3121129
  31599   "^DD",560. 1,560.101, 0,"NM","DA TA")
  31600  
  31601   "^DD",560. 1,560.101, 0,"UP")
  31602   560.1
  31603   "^DD",560. 1,560.101, .01,0)
  31604   DATA^Wx^^0 ;1^Q
  31605   "^DD",560. 1,560.101, .01,21,0)
  31606   ^^1^1^3121 129^
  31607   "^DD",560. 1,560.101, .01,21,1,0 )
  31608   JSON data  object
  31609   "^DD",560. 1,560.101, .01,"DT")
  31610   3121129
  31611   "^DD",560. 11,560.11, 0)
  31612   FIELD^^1^3
  31613   "^DD",560. 11,560.11, 0,"DT")
  31614   3121129
  31615   "^DD",560. 11,560.11, 0,"IX","AC NT",560.11 ,.03)
  31616  
  31617   "^DD",560. 11,560.11, 0,"IX","B" ,560.11,.0 1)
  31618  
  31619   "^DD",560. 11,560.11, 0,"IX","C" ,560.11,.0 3)
  31620  
  31621   "^DD",560. 11,560.11, 0,"NM","VP R OBJECT")
  31622  
  31623   "^DD",560. 11,560.11, 0,"VRPK")
  31624   VPR
  31625   "^DD",560. 11,560.11, .01,0)
  31626   UID^RF^^0; 1^K:$L(X)> 63!($L(X)< 3)!'(X'?1P .E) X
  31627   "^DD",560. 11,560.11, .01,1,0)
  31628   ^.1
  31629   "^DD",560. 11,560.11, .01,1,1,0)
  31630   560.11^B
  31631   "^DD",560. 11,560.11, .01,1,1,1)
  31632   S ^VPR(560 .11,"B",$E (X,1,63),D A)=""
  31633   "^DD",560. 11,560.11, .01,1,1,2)
  31634   K ^VPR(560 .11,"B",$E (X,1,63),D A)
  31635   "^DD",560. 11,560.11, .01,3)
  31636   Answer mus t be 3-63  characters  in length .
  31637   "^DD",560. 11,560.11, .01,21,0)
  31638   ^^1^1^3121 129^
  31639   "^DD",560. 11,560.11, .01,21,1,0 )
  31640   The fully  specified  Universal  ID string  for this o bject.
  31641   "^DD",560. 11,560.11, .01,23,0)
  31642   ^^1^1^3121 129^
  31643   "^DD",560. 11,560.11, .01,23,1,0 )
  31644   urn:va:{co llection}: {systemId} :{ien}
  31645   "^DD",560. 11,560.11, .01,"DT")
  31646   3121129
  31647   "^DD",560. 11,560.11, .03,0)
  31648   COLLECTION ^F^^0;3^K: $L(X)>30!( $L(X)<3) X
  31649   "^DD",560. 11,560.11, .03,1,0)
  31650   ^.1
  31651   "^DD",560. 11,560.11, .03,1,1,0)
  31652   560.11^C
  31653   "^DD",560. 11,560.11, .03,1,1,1)
  31654   S ^VPR(560 .11,"C",$E (X,1,30),D A)=""
  31655   "^DD",560. 11,560.11, .03,1,1,2)
  31656   K ^VPR(560 .11,"C",$E (X,1,30),D A)
  31657   "^DD",560. 11,560.11, .03,1,1,"D T")
  31658   3121129
  31659   "^DD",560. 11,560.11, .03,1,2,0)
  31660   560.11^ACN T^MUMPS
  31661   "^DD",560. 11,560.11, .03,1,2,1)
  31662   S ^VPR(560 .11,"ACNT" ,$E(X,1,30 ))=$G(^VPR (560.11,"A CNT",$E(X, 1,30)))+1
  31663   "^DD",560. 11,560.11, .03,1,2,2)
  31664   S ^VPR(560 .11,"ACNT" ,$E(X,1,30 ))=$G(^VPR (560.11,"A CNT",$E(X, 1,30)))-1
  31665   "^DD",560. 11,560.11, .03,1,2,"% D",0)
  31666   ^^1^1^3140 503^
  31667   "^DD",560. 11,560.11, .03,1,2,"% D",1,0)
  31668   Maintain a  count of  the number  of items  in each co llection.
  31669   "^DD",560. 11,560.11, .03,1,2,"D T")
  31670   3140503
  31671   "^DD",560. 11,560.11, .03,3)
  31672   Answer mus t be 3-30  characters  in length .
  31673   "^DD",560. 11,560.11, .03,21,0)
  31674   ^^1^1^3121 129^
  31675   "^DD",560. 11,560.11, .03,21,1,0 )
  31676   The name o f the type  or kind o f data thi s object b elongs to.
  31677   "^DD",560. 11,560.11, .03,"DT")
  31678   3140503
  31679   "^DD",560. 11,560.11, 1,0)
  31680   DATA^560.1 11^^1;0
  31681   "^DD",560. 11,560.111 ,0)
  31682   DATA SUB-F IELD^^.01^ 1
  31683   "^DD",560. 11,560.111 ,0,"DT")
  31684   3121129
  31685   "^DD",560. 11,560.111 ,0,"NM","D ATA")
  31686  
  31687   "^DD",560. 11,560.111 ,0,"UP")
  31688   560.11
  31689   "^DD",560. 11,560.111 ,.01,0)
  31690   DATA^Wx^^0 ;1^Q
  31691   "^DD",560. 11,560.111 ,.01,21,0)
  31692   ^^1^1^3121 129^
  31693   "^DD",560. 11,560.111 ,.01,21,1, 0)
  31694   JSON data  object
  31695   "^DD",560. 11,560.111 ,.01,"DT")
  31696   3121129
  31697   "^DD",561, 561,0)
  31698   FIELD^^.03 ^4
  31699   "^DD",561, 561,0,"DDA ")
  31700   N
  31701   "^DD",561, 561,0,"DT" )
  31702   3110729
  31703   "^DD",561, 561,0,"IX" ,"B",561,. 01)
  31704  
  31705   "^DD",561, 561,0,"IX" ,"C",561,. 03)
  31706  
  31707   "^DD",561, 561,0,"NM" ,"VPR PANE L")
  31708  
  31709   "^DD",561, 561,0,"PT" ,561.21,.0 2)
  31710  
  31711   "^DD",561, 561,0,"VRP K")
  31712   VPR
  31713   "^DD",561, 561,.01,0)
  31714   NAME^R*P81 0.4'^PXRM( 810.4,^0;1 ^S DIC("S" )="I $P(^( 0),U,3)=3"  D ^DIC K  DIC S DIC= DIE,X=+Y K :Y<0 X
  31715   "^DD",561, 561,.01,1, 0)
  31716   ^.1
  31717   "^DD",561, 561,.01,1, 1,0)
  31718   561^B
  31719   "^DD",561, 561,.01,1, 1,1)
  31720   S ^VPRPANE L("B",$E(X ,1,30),DA) =""
  31721   "^DD",561, 561,.01,1, 1,2)
  31722   K ^VPRPANE L("B",$E(X ,1,30),DA)
  31723   "^DD",561, 561,.01,3)
  31724  
  31725   "^DD",561, 561,.01,12 )
  31726   Only selec t RULE SET  types
  31727   "^DD",561, 561,.01,12 .1)
  31728   S DIC("S") ="I $P(^(0 ),U,3)=3"
  31729   "^DD",561, 561,.01,"D T")
  31730   3110629
  31731   "^DD",561, 561,.02,0)
  31732   DISPLAY NA ME^RF^^0;2 ^K:$L(X)>5 0!($L(X)<3 ) X
  31733   "^DD",561, 561,.02,3)
  31734   Answer mus t be 3-50  characters  in length .
  31735   "^DD",561, 561,.02,"D T")
  31736   3110630
  31737   "^DD",561, 561,.03,0)
  31738   PATIENT LI ST NAME^F^ ^0;3^K:$L( X)>40!($L( X)<3) X
  31739   "^DD",561, 561,.03,1, 0)
  31740   ^.1
  31741   "^DD",561, 561,.03,1, 1,0)
  31742   561^C
  31743   "^DD",561, 561,.03,1, 1,1)
  31744   S ^VPRPANE L("C",$E(X ,1,30),DA) =""
  31745   "^DD",561, 561,.03,1, 1,2)
  31746   K ^VPRPANE L("C",$E(X ,1,30),DA)
  31747   "^DD",561, 561,.03,1, 1,"DT")
  31748   3111006
  31749   "^DD",561, 561,.03,3)
  31750   Answer mus t be 3-40  characters  in length .
  31751   "^DD",561, 561,.03,"D T")
  31752   3111006
  31753   "^DD",561, 561,5,0)
  31754   ORDER DIAL OGS^561.05 P^^ORDER D IALOGS;0
  31755   "^DD",561, 561.05,0)
  31756   ORDER DIAL OGS SUB-FI ELD^^.01^1
  31757   "^DD",561, 561.05,0," DT")
  31758   3110629
  31759   "^DD",561, 561.05,0," IX","B",56 1.05,.01)
  31760  
  31761   "^DD",561, 561.05,0," NM","ORDER  DIALOGS")
  31762  
  31763   "^DD",561, 561.05,0," UP")
  31764   561
  31765   "^DD",561, 561.05,.01 ,0)
  31766   ORDER DIAL OGS^MP101. 41'^ORD(10 1.41,^0;1^ Q
  31767   "^DD",561, 561.05,.01 ,1,0)
  31768   ^.1
  31769   "^DD",561, 561.05,.01 ,1,1,0)
  31770   561.05^B
  31771   "^DD",561, 561.05,.01 ,1,1,1)
  31772   S ^VPRPANE L(DA(1),"O RDER DIALO GS","B",$E (X,1,30),D A)=""
  31773   "^DD",561, 561.05,.01 ,1,1,2)
  31774   K ^VPRPANE L(DA(1),"O RDER DIALO GS","B",$E (X,1,30),D A)
  31775   "^DD",561, 561.05,.01 ,"DT")
  31776   3110629
  31777   "^DD",561. 2,561.2,0)
  31778   FIELD^^3^1 0
  31779   "^DD",561. 2,561.2,0, "DT")
  31780   3130717
  31781   "^DD",561. 2,561.2,0, "IX","AB", 561.23,.01 )
  31782  
  31783   "^DD",561. 2,561.2,0, "IX","AC", 561.2,.04)
  31784  
  31785   "^DD",561. 2,561.2,0, "IX","AD", 561.21,.02 )
  31786  
  31787   "^DD",561. 2,561.2,0, "IX","ATS" ,561.2,99)
  31788  
  31789   "^DD",561. 2,561.2,0, "IX","B",5 61.2,.01)
  31790  
  31791   "^DD",561. 2,561.2,0, "NM","VPRO STER")
  31792  
  31793   "^DD",561. 2,561.2,0, "PT",560.0 2,.01)
  31794  
  31795   "^DD",561. 2,561.2,0, "PT",561.2 1,.02)
  31796  
  31797   "^DD",561. 2,561.2,0, "VRPK")
  31798   VPR
  31799   "^DD",561. 2,561.2,.0 1,0)
  31800   NAME^RF^^0 ;1^K:$L(X) >104!($L(X )<3)!'(X'? 1P.E) X
  31801   "^DD",561. 2,561.2,.0 1,1,0)
  31802   ^.1
  31803   "^DD",561. 2,561.2,.0 1,1,1,0)
  31804   561.2^B
  31805   "^DD",561. 2,561.2,.0 1,1,1,1)
  31806   S ^VPROSTE R("B",$E(X ,1,30),DA) =""
  31807   "^DD",561. 2,561.2,.0 1,1,1,2)
  31808   K ^VPROSTE R("B",$E(X ,1,30),DA)
  31809   "^DD",561. 2,561.2,.0 1,3)
  31810   Answer mus t be 3-104  character s in lengt h.
  31811   "^DD",561. 2,561.2,.0 1,"DT")
  31812   3130220
  31813   "^DD",561. 2,561.2,.0 2,0)
  31814   DISPLAY NA ME^F^^0;2^ K:$L(X)>45 !($L(X)<3)  X
  31815   "^DD",561. 2,561.2,.0 2,3)
  31816   Answer mus t be 3-45  characters  in length .
  31817   "^DD",561. 2,561.2,.0 2,"DT")
  31818   3110830
  31819   "^DD",561. 2,561.2,.0 3,0)
  31820   DISABLE^S^ 1:YES;^0;3 ^Q
  31821   "^DD",561. 2,561.2,.0 3,3)
  31822   ENTER A 1  OR YES TO  DISABLE TH IS ROSTER.
  31823   "^DD",561. 2,561.2,.0 3,"DT")
  31824   3110830
  31825   "^DD",561. 2,561.2,.0 4,0)
  31826   OWNER^P200 '^VA(200,^ 0;4^Q
  31827   "^DD",561. 2,561.2,.0 4,1,0)
  31828   ^.1
  31829   "^DD",561. 2,561.2,.0 4,1,1,0)
  31830   561.2^AC
  31831   "^DD",561. 2,561.2,.0 4,1,1,1)
  31832   S ^VPROSTE R("AC",$E( X,1,30),DA )=""
  31833   "^DD",561. 2,561.2,.0 4,1,1,2)
  31834   K ^VPROSTE R("AC",$E( X,1,30),DA )
  31835   "^DD",561. 2,561.2,.0 4,1,1,"%D" ,0)
  31836   ^^1^1^3120 105^
  31837   "^DD",561. 2,561.2,.0 4,1,1,"%D" ,1,0)
  31838   Index all  rosters by  owner.
  31839   "^DD",561. 2,561.2,.0 4,1,1,"DT" )
  31840   3120105
  31841   "^DD",561. 2,561.2,.0 4,3)
  31842   ENTER THE  OWNER OF T HIS ROSTER
  31843   "^DD",561. 2,561.2,.0 4,"DT")
  31844   3120105
  31845   "^DD",561. 2,561.2,.0 5,0)
  31846   TYPE^RS^PU :PUBLIC;PR :PRIVATE;^ 0;5^Q
  31847   "^DD",561. 2,561.2,.0 5,"DT")
  31848   3111115
  31849   "^DD",561. 2,561.2,.0 6,0)
  31850   PATIENT LI ST NAME^F^ ^0;6^K:$L( X)>40!($L( X)<3) X
  31851   "^DD",561. 2,561.2,.0 6,3)
  31852   Answer mus t be 3-40  characters  in length .
  31853   "^DD",561. 2,561.2,.0 6,"DT")
  31854   3120120
  31855   "^DD",561. 2,561.2,1, 0)
  31856   SOURCES^56 1.21^^1;0
  31857   "^DD",561. 2,561.2,2, 0)
  31858   SPECIAL HA NDLING^K^^ 3;E1,245^K :$L(X)>245  X D:$D(X)  ^DIM
  31859   "^DD",561. 2,561.2,2, 3)
  31860   This is St andard MUM PS code.
  31861   "^DD",561. 2,561.2,2, 9)
  31862   @
  31863   "^DD",561. 2,561.2,2, "DT")
  31864   3120103
  31865   "^DD",561. 2,561.2,3, 0)
  31866   PATIENT^56 1.23P^^4;0
  31867   "^DD",561. 2,561.2,99 ,0)
  31868   TIMESTAMP^ D^^2;1^S % DT="ESTXR"  D ^%DT S  X=Y K:3110 830.0839>X  X
  31869   "^DD",561. 2,561.2,99 ,1,0)
  31870   ^.1
  31871   "^DD",561. 2,561.2,99 ,1,1,0)
  31872   561.2^ATS
  31873   "^DD",561. 2,561.2,99 ,1,1,1)
  31874   S ^VPROSTE R("ATS",$E (X,1,30),D A)=""
  31875   "^DD",561. 2,561.2,99 ,1,1,2)
  31876   K ^VPROSTE R("ATS",$E (X,1,30),D A)
  31877   "^DD",561. 2,561.2,99 ,1,1,"DT")
  31878   3110831
  31879   "^DD",561. 2,561.2,99 ,3)
  31880   Type a dat e not earl ier than A UG 30, 201 1@08:39.
  31881   "^DD",561. 2,561.2,99 ,"DT")
  31882   3110831
  31883   "^DD",561. 2,561.21,0 )
  31884   SOURCES SU B-FIELD^^. 05^5
  31885   "^DD",561. 2,561.21,0 ,"DT")
  31886   3120119
  31887   "^DD",561. 2,561.21,0 ,"IX","AS" ,561.21,.0 1)
  31888  
  31889   "^DD",561. 2,561.21,0 ,"IX","B", 561.21,.01 )
  31890  
  31891   "^DD",561. 2,561.21,0 ,"NM","SOU RCES")
  31892  
  31893   "^DD",561. 2,561.21,0 ,"UP")
  31894   561.2
  31895   "^DD",561. 2,561.21,. 01,0)
  31896   SEQUENCE^M NJ8,0^^0;1 ^K:+X'=X!( X>99999999 )!(X<1)!(X ?.E1"."1.N ) X
  31897   "^DD",561. 2,561.21,. 01,1,0)
  31898   ^.1
  31899   "^DD",561. 2,561.21,. 01,1,1,0)
  31900   561.21^B
  31901   "^DD",561. 2,561.21,. 01,1,1,1)
  31902   S ^VPROSTE R(DA(1),1, "B",$E(X,1 ,30),DA)=" "
  31903   "^DD",561. 2,561.21,. 01,1,1,2)
  31904   K ^VPROSTE R(DA(1),1, "B",$E(X,1 ,30),DA)
  31905   "^DD",561. 2,561.21,. 01,1,2,0)
  31906   561.21^AS
  31907   "^DD",561. 2,561.21,. 01,1,2,1)
  31908   S ^VPROSTE R(DA(1),1, "AS",$E(X, 1,30),DA)= ""
  31909   "^DD",561. 2,561.21,. 01,1,2,2)
  31910   K ^VPROSTE R(DA(1),1, "AS",$E(X, 1,30),DA)
  31911   "^DD",561. 2,561.21,. 01,1,2,"DT ")
  31912   3110901
  31913   "^DD",561. 2,561.21,. 01,3)
  31914   Type a num ber betwee n 1 and 99 999999, 0  decimal di gits.
  31915   "^DD",561. 2,561.21,. 01,"DT")
  31916   3110901
  31917   "^DD",561. 2,561.21,. 02,0)
  31918   SOURCE^RV^ ^0;2^Q
  31919   "^DD",561. 2,561.21,. 02,1,0)
  31920   ^.1
  31921   "^DD",561. 2,561.21,. 02,1,1,0)
  31922   561.2^AD
  31923   "^DD",561. 2,561.21,. 02,1,1,1)
  31924   S ^VPROSTE R("AD",$E( X,1,30),DA (1),DA)=""
  31925   "^DD",561. 2,561.21,. 02,1,1,2)
  31926   K ^VPROSTE R("AD",$E( X,1,30),DA (1),DA)
  31927   "^DD",561. 2,561.21,. 02,1,1,"DT ")
  31928   3131126
  31929   "^DD",561. 2,561.21,. 02,3)
  31930   ENTER FILE  WHICH WIL L BE THE S OURCE FOR  THIS ROSTE R
  31931   "^DD",561. 2,561.21,. 02,"DT")
  31932   3131126
  31933   "^DD",561. 2,561.21,. 02,"V",0)
  31934   ^.12P^12^1 0
  31935   "^DD",561. 2,561.21,. 02,"V",1,0 )
  31936   2^PATIENT^ 1^PAT^n^n
  31937   "^DD",561. 2,561.21,. 02,"V",1,1 )
  31938  
  31939   "^DD",561. 2,561.21,. 02,"V",1,2 )
  31940  
  31941   "^DD",561. 2,561.21,. 02,"V",2,0 )
  31942   42^WARD LO CATION^2^W ARD^n^n
  31943   "^DD",561. 2,561.21,. 02,"V",2,1 )
  31944  
  31945   "^DD",561. 2,561.21,. 02,"V",2,2 )
  31946  
  31947   "^DD",561. 2,561.21,. 02,"V",3,0 )
  31948   44^CLINIC^ 3^CL^n^n
  31949   "^DD",561. 2,561.21,. 02,"V",3,1 )
  31950  
  31951   "^DD",561. 2,561.21,. 02,"V",3,2 )
  31952  
  31953   "^DD",561. 2,561.21,. 02,"V",5,0 )
  31954   200^PROVID ER^5^PROV^ n^n
  31955   "^DD",561. 2,561.21,. 02,"V",5,1 )
  31956  
  31957   "^DD",561. 2,561.21,. 02,"V",5,2 )
  31958  
  31959   "^DD",561. 2,561.21,. 02,"V",6,0 )
  31960   100.21^CPR S^6^CPRS^n ^n
  31961   "^DD",561. 2,561.21,. 02,"V",6,1 )
  31962  
  31963   "^DD",561. 2,561.21,. 02,"V",6,2 )
  31964  
  31965   "^DD",561. 2,561.21,. 02,"V",7,0 )
  31966   404.51^PCM M TEAM^7^P CMM^n^n
  31967   "^DD",561. 2,561.21,. 02,"V",7,1 )
  31968  
  31969   "^DD",561. 2,561.21,. 02,"V",7,2 )
  31970  
  31971   "^DD",561. 2,561.21,. 02,"V",8,0 )
  31972   810.4^REMI NDER'S LIS T RULE FIL E^22^PXRM^ y^n
  31973   "^DD",561. 2,561.21,. 02,"V",8,1 )
  31974   S DIC("S") ="I $P(^(0 ),U,3)=3"
  31975   "^DD",561. 2,561.21,. 02,"V",8,2 )
  31976   Only selec t Rule Set  types
  31977   "^DD",561. 2,561.21,. 02,"V",9,0 )
  31978   561.2^VPR  ROSTER FIL E^9^ROST^^ n
  31979   "^DD",561. 2,561.21,. 02,"V",11, 0)
  31980   45.7^SPECI ALTY^70^SP EC^n^n
  31981   "^DD",561. 2,561.21,. 02,"V",12, 0)
  31982   561^Select  VPR Panel  List Rule ^80^VPRPAN ^n^n
  31983   "^DD",561. 2,561.21,. 03,0)
  31984   OPERATION^ S^0:UNION; 1:INTERSEC TION;2:DIF FERENCE;^0 ;3^Q
  31985   "^DD",561. 2,561.21,. 03,"DT")
  31986   3110830
  31987   "^DD",561. 2,561.21,. 04,0)
  31988   FILTER^S^T :TODAY;^0; 4^Q
  31989   "^DD",561. 2,561.21,. 04,3)
  31990  
  31991   "^DD",561. 2,561.21,. 04,"DT")
  31992   3110901
  31993   "^DD",561. 2,561.21,. 05,0)
  31994   REFRESH FR EQUENCY^S^ D:DAILY;H: HOURLY;^0; 5^Q
  31995   "^DD",561. 2,561.21,. 05,3)
  31996  
  31997   "^DD",561. 2,561.21,. 05,"DT")
  31998   3120119
  31999   "^DD",561. 2,561.23,0 )
  32000   PATIENT SU B-FIELD^^. 02^2
  32001   "^DD",561. 2,561.23,0 ,"DT")
  32002   3130717
  32003   "^DD",561. 2,561.23,0 ,"IX","B", 561.23,.01 )
  32004  
  32005   "^DD",561. 2,561.23,0 ,"NM","PAT IENT")
  32006  
  32007   "^DD",561. 2,561.23,0 ,"UP")
  32008   561.2
  32009   "^DD",561. 2,561.23,. 01,0)
  32010   PATIENT^MP 2'^DPT(^0; 1^Q
  32011   "^DD",561. 2,561.23,. 01,1,0)
  32012   ^.1
  32013   "^DD",561. 2,561.23,. 01,1,1,0)
  32014   561.23^B
  32015   "^DD",561. 2,561.23,. 01,1,1,1)
  32016   S ^VPROSTE R(DA(1),4, "B",$E(X,1 ,30),DA)=" "
  32017   "^DD",561. 2,561.23,. 01,1,1,2)
  32018   K ^VPROSTE R(DA(1),4, "B",$E(X,1 ,30),DA)
  32019   "^DD",561. 2,561.23,. 01,1,2,0)
  32020   561.2^AB
  32021   "^DD",561. 2,561.23,. 01,1,2,1)
  32022   S ^VPROSTE R("AB",$E( X,1,30),DA (1),DA)=""
  32023   "^DD",561. 2,561.23,. 01,1,2,2)
  32024   K ^VPROSTE R("AB",$E( X,1,30),DA (1),DA)
  32025   "^DD",561. 2,561.23,. 01,1,2,"%D ",0)
  32026   ^^1^1^3121 220^
  32027   "^DD",561. 2,561.23,. 01,1,2,"%D ",1,0)
  32028   Index of a ll rosters  patient i s in.
  32029   "^DD",561. 2,561.23,. 01,1,2,"DT ")
  32030   3121220
  32031   "^DD",561. 2,561.23,. 01,"DT")
  32032   3121220
  32033   "^DD",561. 2,561.23,. 02,0)
  32034   SRCSEQ^NJ6 ,0^^0;2^K: +X'=X!(X>9 99999)!(X< 1)!(X?.E1" ."1N.N) X
  32035   "^DD",561. 2,561.23,. 02,3)
  32036   Type a num ber betwee n 1 and 99 9999, 0 de cimal digi ts.
  32037   "^DD",561. 2,561.23,. 02,"DT")
  32038   3130717
  32039   "^DIC",100 .98,100.98 ,0)
  32040   DISPLAY GR OUP^100.98 I
  32041   "^DIC",100 .98,100.98 ,0,"GL")
  32042   ^ORD(100.9 8,
  32043   "^DIC",100 .98,100.98 ,"%D",0)
  32044   ^^5^5^2971 218^^^^
  32045   "^DIC",100 .98,100.98 ,"%D",1,0)
  32046   This file  allows ord ers to be  clustered  in groups  other than  by packag e.
  32047   "^DIC",100 .98,100.98 ,"%D",2,0)
  32048   It is simi lar in str ucture to  the OPTION  File (19) .  This al lows displ ay
  32049   "^DIC",100 .98,100.98 ,"%D",3,0)
  32050   groups to  be arrange d in a hie rarchy.  T he main en try in thi s file
  32051   "^DIC",100 .98,100.98 ,"%D",4,0)
  32052   should be  'ALL SERVI CES'.  Oth er entries  should be  logically  subordina te
  32053   "^DIC",100 .98,100.98 ,"%D",5,0)
  32054   to the 'AL L SERVICES ' entry.
  32055   "^DIC",100 .98,"B","D ISPLAY GRO UP",100.98 )
  32056  
  32057   "^DIC",101 .41,101.41 ,0)
  32058   ORDER DIAL OG^101.41
  32059   "^DIC",101 .41,101.41 ,0,"GL")
  32060   ^ORD(101.4 1,
  32061   "^DIC",101 .41,101.41 ,"%D",0)
  32062   ^^2^2^2960 819^^
  32063   "^DIC",101 .41,101.41 ,"%D",1,0)
  32064   This file  contains t he informa tion neede d to defin e how to p rompt for  each
  32065   "^DIC",101 .41,101.41 ,"%D",2,0)
  32066   order, wha t values a re accepta ble, etc.
  32067   "^DIC",101 .41,"B","O RDER DIALO G",101.41)
  32068  
  32069   "^DIC",560 ,560,0)
  32070   VPR SUBSCR IPTION^560
  32071   "^DIC",560 ,560,0,"GL ")
  32072   ^VPR(560,
  32073   "^DIC",560 ,"B","VPR  SUBSCRIPTI ON",560)
  32074  
  32075   "^DIC",560 .1,560.1,0 )
  32076   VPR PATIEN T OBJECT^5 60.1
  32077   "^DIC",560 .1,560.1,0 ,"GL")
  32078   ^VPR(560.1 ,
  32079   "^DIC",560 .1,560.1," %",0)
  32080   ^1.005^^0
  32081   "^DIC",560 .1,"B","VP R PATIENT  OBJECT",56 0.1)
  32082  
  32083   "^DIC",560 .11,560.11 ,0)
  32084   VPR OBJECT ^560.11
  32085   "^DIC",560 .11,560.11 ,0,"GL")
  32086   ^VPR(560.1 1,
  32087   "^DIC",560 .11,"B","V PR OBJECT" ,560.11)
  32088  
  32089   "^DIC",561 ,561,0)
  32090   VPR PANEL^ 561
  32091   "^DIC",561 ,561,0,"GL ")
  32092   ^VPRPANEL(
  32093   "^DIC",561 ,561,"%",0 )
  32094   ^1.005^1^1
  32095   "^DIC",561 ,561,"%",1 ,0)
  32096   VPR
  32097   "^DIC",561 ,561,"%"," B","VPR",1 )
  32098  
  32099   "^DIC",561 ,561,"%D", 0)
  32100   ^1.001^4^4 ^3110701^^ ^
  32101   "^DIC",561 ,561,"%D", 1,0)
  32102   Contains t he Rule Se ts that co ntain the  cohorts fo r creating  patient p anels.
  32103   "^DIC",561 ,561,"%D", 2,0)
  32104   For exampl e, panel w hich inclu des Diabet ic patient s will be  created
  32105   "^DIC",561 ,561,"%D", 3,0)
  32106   nightly to  update th e list of  patients.   All panel s in this  file will  be
  32107   "^DIC",561 ,561,"%D", 4,0)
  32108   updated ni ghtly.
  32109   "^DIC",561 ,"B","VPR  PANEL",561 )
  32110  
  32111   "^DIC",561 .2,561.2,0 )
  32112   VPROSTER^5 61.2
  32113   "^DIC",561 .2,561.2,0 ,"GL")
  32114   ^VPROSTER(
  32115   "^DIC",561 .2,"B","VP ROSTER",56 1.2)
  32116  
  32117   **INSTALL  NAME**
  32118   TIU*1.0*10 6
  32119   "BLD",8919 ,0)
  32120   TIU*1.0*10 6^TEXT INT EGRATION U TILITIES^0 ^3140611^y
  32121   "BLD",8919 ,1,0)
  32122   ^^1^1^3140 522^
  32123   "BLD",8919 ,1,1,0)
  32124   Support fo r VPR
  32125   "BLD",8919 ,4,0)
  32126   ^9.64PA^^
  32127   "BLD",8919 ,6.3)
  32128   19
  32129   "BLD",8919 ,"INID")
  32130   ^n
  32131   "BLD",8919 ,"INIT")
  32132   MAIN^TIUPS 106
  32133   "BLD",8919 ,"KRN",0)
  32134   ^9.67PA^77 9.2^20
  32135   "BLD",8919 ,"KRN",.4, 0)
  32136   .4
  32137   "BLD",8919 ,"KRN",.40 1,0)
  32138   .401
  32139   "BLD",8919 ,"KRN",.40 2,0)
  32140   .402
  32141   "BLD",8919 ,"KRN",.40 3,0)
  32142   .403
  32143   "BLD",8919 ,"KRN",.5, 0)
  32144   .5
  32145   "BLD",8919 ,"KRN",.84 ,0)
  32146   .84
  32147   "BLD",8919 ,"KRN",3.6 ,0)
  32148   3.6
  32149   "BLD",8919 ,"KRN",3.8 ,0)
  32150   3.8
  32151   "BLD",8919 ,"KRN",9.2 ,0)
  32152   9.2
  32153   "BLD",8919 ,"KRN",9.8 ,0)
  32154   9.8
  32155   "BLD",8919 ,"KRN",9.8 ,"NM",0)
  32156   ^9.68A^2^2
  32157   "BLD",8919 ,"KRN",9.8 ,"NM",1,0)
  32158   TIUPS106^^ 0^B3246449
  32159   "BLD",8919 ,"KRN",9.8 ,"NM",2,0)
  32160   TIUVPR^^0^ B3758863
  32161   "BLD",8919 ,"KRN",9.8 ,"NM","B", "TIUPS106" ,1)
  32162  
  32163   "BLD",8919 ,"KRN",9.8 ,"NM","B", "TIUVPR",2 )
  32164  
  32165   "BLD",8919 ,"KRN",19, 0)
  32166   19
  32167   "BLD",8919 ,"KRN",19. 1,0)
  32168   19.1
  32169   "BLD",8919 ,"KRN",101 ,0)
  32170   101
  32171   "BLD",8919 ,"KRN",409 .61,0)
  32172   409.61
  32173   "BLD",8919 ,"KRN",771 ,0)
  32174   771
  32175   "BLD",8919 ,"KRN",779 .2,0)
  32176   779.2
  32177   "BLD",8919 ,"KRN",870 ,0)
  32178   870
  32179   "BLD",8919 ,"KRN",898 9.51,0)
  32180   8989.51
  32181   "BLD",8919 ,"KRN",898 9.52,0)
  32182   8989.52
  32183   "BLD",8919 ,"KRN",899 4,0)
  32184   8994
  32185   "BLD",8919 ,"KRN","B" ,.4,.4)
  32186  
  32187   "BLD",8919 ,"KRN","B" ,.401,.401 )
  32188  
  32189   "BLD",8919 ,"KRN","B" ,.402,.402 )
  32190  
  32191   "BLD",8919 ,"KRN","B" ,.403,.403 )
  32192  
  32193   "BLD",8919 ,"KRN","B" ,.5,.5)
  32194  
  32195   "BLD",8919 ,"KRN","B" ,.84,.84)
  32196  
  32197   "BLD",8919 ,"KRN","B" ,3.6,3.6)
  32198  
  32199   "BLD",8919 ,"KRN","B" ,3.8,3.8)
  32200  
  32201   "BLD",8919 ,"KRN","B" ,9.2,9.2)
  32202  
  32203   "BLD",8919 ,"KRN","B" ,9.8,9.8)
  32204  
  32205   "BLD",8919 ,"KRN","B" ,19,19)
  32206  
  32207   "BLD",8919 ,"KRN","B" ,19.1,19.1 )
  32208  
  32209   "BLD",8919 ,"KRN","B" ,101,101)
  32210  
  32211   "BLD",8919 ,"KRN","B" ,409.61,40 9.61)
  32212  
  32213   "BLD",8919 ,"KRN","B" ,771,771)
  32214  
  32215   "BLD",8919 ,"KRN","B" ,779.2,779 .2)
  32216  
  32217   "BLD",8919 ,"KRN","B" ,870,870)
  32218  
  32219   "BLD",8919 ,"KRN","B" ,8989.51,8 989.51)
  32220  
  32221   "BLD",8919 ,"KRN","B" ,8989.52,8 989.52)
  32222  
  32223   "BLD",8919 ,"KRN","B" ,8994,8994 )
  32224  
  32225   "BLD",8919 ,"QUES",0)
  32226   ^9.62^^
  32227   "BLD",8919 ,"REQB",0)
  32228   ^9.611^^
  32229   "INIT")
  32230   MAIN^TIUPS 106
  32231   "MBREQ")
  32232   1
  32233   "PKG",516, -1)
  32234   1^1
  32235   "PKG",516, 0)
  32236   TEXT INTEG RATION UTI LITIES^TIU ^Text Inte gration Ut ilities 
  32237   "PKG",516, 20,0)
  32238   ^9.402P^^
  32239   "PKG",516, 22,0)
  32240   ^9.49I^1^1
  32241   "PKG",516, 22,1,0)
  32242   1.0^297062 0^2970815^ 11712
  32243   "PKG",516, 22,1,"PAH" ,1,0)
  32244   106^314061 1^1085
  32245   "PKG",516, 22,1,"PAH" ,1,1,0)
  32246   ^^1^1^3140 611
  32247   "PKG",516, 22,1,"PAH" ,1,1,1,0)
  32248   Support fo r VPR
  32249   "QUES","XP F1",0)
  32250   Y
  32251   "QUES","XP F1","??")
  32252   ^D REP^XPD H
  32253   "QUES","XP F1","A")
  32254   Shall I wr ite over y our |FLAG|  File
  32255   "QUES","XP F1","B")
  32256   YES
  32257   "QUES","XP F1","M")
  32258   D XPF1^XPD IQ
  32259   "QUES","XP F2",0)
  32260   Y
  32261   "QUES","XP F2","??")
  32262   ^D DTA^XPD H
  32263   "QUES","XP F2","A")
  32264   Want my da ta |FLAG|  yours
  32265   "QUES","XP F2","B")
  32266   YES
  32267   "QUES","XP F2","M")
  32268   D XPF2^XPD IQ
  32269   "QUES","XP I1",0)
  32270   YO
  32271   "QUES","XP I1","??")
  32272   ^D INHIBIT ^XPDH
  32273   "QUES","XP I1","A")
  32274   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  32275   "QUES","XP I1","B")
  32276   NO
  32277   "QUES","XP I1","M")
  32278   D XPI1^XPD IQ
  32279   "QUES","XP M1",0)
  32280   PO^VA(200, :EM
  32281   "QUES","XP M1","??")
  32282   ^D MG^XPDH
  32283   "QUES","XP M1","A")
  32284   Enter the  Coordinato r for Mail  Group '|F LAG|'
  32285   "QUES","XP M1","B")
  32286  
  32287   "QUES","XP M1","M")
  32288   D XPM1^XPD IQ
  32289   "QUES","XP O1",0)
  32290   Y
  32291   "QUES","XP O1","??")
  32292   ^D MENU^XP DH
  32293   "QUES","XP O1","A")
  32294   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  32295   "QUES","XP O1","B")
  32296   NO
  32297   "QUES","XP O1","M")
  32298   D XPO1^XPD IQ
  32299   "QUES","XP Z1",0)
  32300   Y
  32301   "QUES","XP Z1","??")
  32302   ^D OPT^XPD H
  32303   "QUES","XP Z1","A")
  32304   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  32305   "QUES","XP Z1","B")
  32306   NO
  32307   "QUES","XP Z1","M")
  32308   D XPZ1^XPD IQ
  32309   "QUES","XP Z2",0)
  32310   Y
  32311   "QUES","XP Z2","??")
  32312   ^D RTN^XPD H
  32313   "QUES","XP Z2","A")
  32314   Want to MO VE routine s to other  CPUs
  32315   "QUES","XP Z2","B")
  32316   NO
  32317   "QUES","XP Z2","M")
  32318   D XPZ2^XPD IQ
  32319   "RTN")
  32320   2
  32321   "RTN","TIU PS106")
  32322   0^1^B32464 49
  32323   "RTN","TIU PS106",1,0 )
  32324   TIUPS106 ;  SLC/JER,M KB - post  install fo r 106 ;14- MAY-2004 [ 9/21/04 1: 07pm]
  32325   "RTN","TIU PS106",2,0 )
  32326    ;;1.0;TEX T INTEGRAT ION UTILIT IES;**106* *;Jun 20,  1997;Build  19
  32327   "RTN","TIU PS106",3,0 )
  32328   MAIN ;cont rols branc hing
  32329   "RTN","TIU PS106",4,0 )
  32330    D NEWXREF
  32331   "RTN","TIU PS106",5,0 )
  32332    Q
  32333   "RTN","TIU PS106",6,0 )
  32334   NEWXREF ;c reates new  index "AV PR" to sup port the V PR
  32335   "RTN","TIU PS106",7,0 )
  32336    I $O(^DD( "IX","BB", 8925,"AVPR ",0)) D DE LIXN^DDMOD (8925,"AVP R","W")
  32337   "RTN","TIU PS106",8,0 )
  32338    N TIUARR, TIURES
  32339   "RTN","TIU PS106",9,0 )
  32340    S TIUARR( "FILE")=89 25
  32341   "RTN","TIU PS106",10, 0)
  32342    S TIUARR( "NAME")="A VPR"
  32343   "RTN","TIU PS106",11, 0)
  32344    S TIUARR( "TYPE")="M U"
  32345   "RTN","TIU PS106",12, 0)
  32346    S TIUARR( "USE")="A"
  32347   "RTN","TIU PS106",13, 0)
  32348    S TIUARR( "EXECUTION ")="R"
  32349   "RTN","TIU PS106",14, 0)
  32350    S TIUARR( "ACTIVITY" )=""
  32351   "RTN","TIU PS106",15, 0)
  32352    S TIUARR( "SET CONDI TION")="S  X=(X2(12)' ="""")" ;P atient def ined
  32353   "RTN","TIU PS106",16, 0)
  32354    S TIUARR( "KILL COND ITION")="S  X=(X2(1)= """")" ;Do cument typ e deleted
  32355   "RTN","TIU PS106",17, 0)
  32356    S TIUARR( "SET")="D  TIU^VPREVN T(X2(12),D A)"
  32357   "RTN","TIU PS106",18, 0)
  32358    S TIUARR( "KILL")="D  TIU^VPREV NT(X2(12), DA)"
  32359   "RTN","TIU PS106",19, 0)
  32360    S TIUARR( "SHORT DES CR")="Trig ger update s to VPR"
  32361   "RTN","TIU PS106",20, 0)
  32362    S TIUARR( "DESCR",1) ="This is  an action  index that  updates t he VPR"
  32363   "RTN","TIU PS106",21, 0)
  32364    S TIUARR( "DESCR",2) ="  when a ny of the  fields in  this index  are"
  32365   "RTN","TIU PS106",22, 0)
  32366    S TIUARR( "DESCR",3) ="  change d.  The in dex will n ot fire if  there"
  32367   "RTN","TIU PS106",23, 0)
  32368    S TIUARR( "DESCR",4) ="  is no  patient de fined for  the docume nt."
  32369   "RTN","TIU PS106",24, 0)
  32370    S TIUARR( "VAL",1)=. 01
  32371   "RTN","TIU PS106",25, 0)
  32372    S TIUARR( "VAL",2)=. 05
  32373   "RTN","TIU PS106",26, 0)
  32374    S TIUARR( "VAL",3)=. 06
  32375   "RTN","TIU PS106",27, 0)
  32376    S TIUARR( "VAL",4)=. 07
  32377   "RTN","TIU PS106",28, 0)
  32378    S TIUARR( "VAL",5)=. 08
  32379   "RTN","TIU PS106",29, 0)
  32380    S TIUARR( "VAL",6)=1 202
  32381   "RTN","TIU PS106",30, 0)
  32382    S TIUARR( "VAL",7)=1 205
  32383   "RTN","TIU PS106",31, 0)
  32384    S TIUARR( "VAL",8)=1 301
  32385   "RTN","TIU PS106",32, 0)
  32386    S TIUARR( "VAL",9)=1 405
  32387   "RTN","TIU PS106",33, 0)
  32388    S TIUARR( "VAL",10)= 1701
  32389   "RTN","TIU PS106",34, 0)
  32390    S TIUARR( "VAL",11)= 2101
  32391   "RTN","TIU PS106",35, 0)
  32392    S TIUARR( "VAL",12)= .02
  32393   "RTN","TIU PS106",36, 0)
  32394    D CREIXN^ DDMOD(.TIU ARR,"W",.T IURES)
  32395   "RTN","TIU PS106",37, 0)
  32396    Q
  32397   "RTN","TIU VPR")
  32398   0^2^B37588 63
  32399   "RTN","TIU VPR",1,0)
  32400   TIUVPR ; S LC/JER-Ser ver functi ons for li sts ;7/9/9 6  12:47 [ 9/21/04 1: 07pm]
  32401   "RTN","TIU VPR",2,0)
  32402    ;;1.0;TEX T INTEGRAT ION UTILIT IES;**106* *;Jun 20,  1997;Build  19
  32403   "RTN","TIU VPR",3,0)
  32404   NOTES(TIUY ,DFN,EARLY ,LATE) ; G ets list o f Notes
  32405   "RTN","TIU VPR",4,0)
  32406    I $S(+$G( DFN)'>0:1, '$D(^DPT(+ $G(DFN),0) ):1,1:0) Q
  32407   "RTN","TIU VPR",5,0)
  32408    D LIST(TI UY,DFN,3,$ G(EARLY),$ G(LATE))
  32409   "RTN","TIU VPR",6,0)
  32410    Q
  32411   "RTN","TIU VPR",7,0)
  32412   SUMMARY(TI UY,DFN,EAR LY,LATE) ;  Gets list  of Summar ies
  32413   "RTN","TIU VPR",8,0)
  32414    I $S(+$G( DFN)'>0:1, '$D(^DPT(+ $G(DFN),0) ):1,1:0) Q
  32415   "RTN","TIU VPR",9,0)
  32416    D LIST(TI UY,DFN,244 ,$G(EARLY) ,$G(LATE))
  32417   "RTN","TIU VPR",10,0)
  32418    Q
  32419   "RTN","TIU VPR",11,0)
  32420   LIST(TIUY, DFN,TYPE,E ARLY,LATE)  ; Build L ist
  32421   "RTN","TIU VPR",12,0)
  32422    N TIUCOUN T,TIUI
  32423   "RTN","TIU VPR",13,0)
  32424    S TIUCOUN T=0
  32425   "RTN","TIU VPR",14,0)
  32426    I +$D(TYP E)'>0 S @T IUY@("COUN T")=0 Q
  32427   "RTN","TIU VPR",15,0)
  32428    S EARLY=9 999999-+$G (EARLY),LA TE=9999999 -$S(+$G(LA TE):+$G(LA TE),1:3333 333)
  32429   "RTN","TIU VPR",16,0)
  32430    S TIUI=LA TE
  32431   "RTN","TIU VPR",17,0)
  32432    F  S TIUI =$O(^TIU(8 925,"APTCL ",DFN,TYPE ,TIUI)) Q: TIUI'>0!(T IUI>EARLY)   D
  32433   "RTN","TIU VPR",18,0)
  32434    . N DA S  DA=0
  32435   "RTN","TIU VPR",19,0)
  32436    . F  S DA =$O(^TIU(8 925,"APTCL ",DFN,TYPE ,TIUI,DA))  Q:+DA'>0   D
  32437   "RTN","TIU VPR",20,0)
  32438    . . S @TI UY@(DA)="" ,TIUCOUNT= TIUCOUNT+1
  32439   "RTN","TIU VPR",21,0)
  32440    S @TIUY@( "COUNT")=$ G(TIUCOUNT )
  32441   "RTN","TIU VPR",22,0)
  32442    Q
  32443   "RTN","TIU VPR",23,0)
  32444    ;
  32445   "RTN","TIU VPR",24,0)
  32446   GET(TIUY,D FN,CLASS,E ARLY,LATE)  ; Build L ist/MKB
  32447   "RTN","TIU VPR",25,0)
  32448    ;   TIUY      - Retu rn array,  pass by re ference
  32449   "RTN","TIU VPR",26,0)
  32450    ;   DFN       - Poin ter to PAT IENT #2
  32451   "RTN","TIU VPR",27,0)
  32452    ;   CLASS     - Poin ter to TIU  DOCUMENT  DEFINITION  #8925.1
  32453   "RTN","TIU VPR",28,0)
  32454    ;  [EARLY ]   - FM d ate/time t o begin se arch
  32455   "RTN","TIU VPR",29,0)
  32456    ;  [LATE]     - FM d ate/time t o end sear ch
  32457   "RTN","TIU VPR",30,0)
  32458    N TIUCOUN T,TIUI,DA
  32459   "RTN","TIU VPR",31,0)
  32460    S TIUCOUN T=0,TIUY=$ NA(^TMP("T IULIST",$J )) K @TIUY
  32461   "RTN","TIU VPR",32,0)
  32462    I +$G(CLA SS)'>0 S C LASS=38 ;S  @TIUY@("C OUNT")=0 Q
  32463   "RTN","TIU VPR",33,0)
  32464    S EARLY=9 999999-+$G (EARLY),TI UI=9999999 -$S(+$G(LA TE):+$G(LA TE),1:3333 333)
  32465   "RTN","TIU VPR",34,0)
  32466    F  S TIUI =$O(^TIU(8 925,"APTCL ",DFN,CLAS S,TIUI)) Q :TIUI<1!(T IUI>EARLY)   D
  32467   "RTN","TIU VPR",35,0)
  32468    . S DA=0  F  S DA=$O (^TIU(8925 ,"APTCL",D FN,CLASS,T IUI,DA)) Q :+DA'>0  D
  32469   "RTN","TIU VPR",36,0)
  32470    . . I +$$ ISADDNDM^T IULC1(+DA)  Q  ;no ad denda
  32471   "RTN","TIU VPR",37,0)
  32472    . . I +$$ ISCOMP^TIU SRVR1(+DA)  Q  ;no co mponents
  32473   "RTN","TIU VPR",38,0)
  32474    . . ;I +$ G(^TIU(892 5,+DA,21))  Q  ;no id  children
  32475   "RTN","TIU VPR",39,0)
  32476    . . S TIU COUNT=TIUC OUNT+1
  32477   "RTN","TIU VPR",40,0)
  32478    . . S @TI UY@(TIUCOU NT)=DA
  32479   "RTN","TIU VPR",41,0)
  32480    S @TIUY@( "COUNT")=$ G(TIUCOUNT )
  32481   "RTN","TIU VPR",42,0)
  32482    Q
  32483   "VER")
  32484   8.0^22.0
  32485   **END**
  32486   **END**